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 &key (error-if-does-not-exist nil))
  41   (let* ((path (canonicalize-directory-name filename))
  42          (probe
  43           #+allegro (excl:probe-directory path)
  44           #+clisp (values
  45                    (ignore-errors
  46                      (#+lisp=cl ext:probe-directory
  47                                 #-lisp=cl lisp:probe-directory
  48                                 path)))
  49           #+(or cmu scl) (when (eq :directory
  50                                    (unix:unix-file-kind (namestring path)))
  51                            path)
  52           #+lispworks (when (lw:file-directory-p path)
  53                         path)
  54           #+sbcl
  55           (let ((file-kind-fun
  56                  (or (find-symbol "NATIVE-FILE-KIND" :sb-impl)
  57                      (find-symbol "UNIX-FILE-KIND" :sb-unix))))
  58             (when (eq :directory (funcall file-kind-fun (namestring path)))
  59               path))
  60           #-(or allegro clisp cmu lispworks sbcl scl)
  61           (probe-file path)))
  62     (if probe
  63         probe
  64         (when error-if-does-not-exist
  65           (error "Directory ~A does not exist." filename)))))
  66
  67 (defun cwd (&optional dir)
  68   "Change directory and set default pathname"
  69   (cond
  70    ((not (null dir))
  71     (when (and (typep dir 'logical-pathname)
  72                (translate-logical-pathname dir))
  73       (setq dir (translate-logical-pathname dir)))
  74     (when (stringp dir)
  75       (setq dir (parse-namestring dir)))
  76     #+allegro (excl:chdir dir)
  77     #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
  78     #+(or cmu scl) (setf (ext:default-directory) dir)
  79     #+cormanlisp (ccl:set-current-directory dir)
  80     #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
  81     #+openmcl (ccl:cwd dir)
  82     #+gcl (si:chdir dir)
  83     #+lispworks (hcl:change-directory dir)
  84     (setq cl:*default-pathname-defaults* dir))
  85    (t
  86     (let ((dir
  87            #+allegro (excl:current-directory)
  88            #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
  89            #+(or cmu scl) (ext:default-directory)
  90            #+sbcl (sb-unix:posix-getcwd/)
  91            #+cormanlisp (ccl:get-current-directory)
  92            #+lispworks (hcl:get-working-directory)
  93            #+mcl (ccl:mac-default-directory)
  94            #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
  95       (when (stringp dir)
  96         (setq dir (parse-namestring dir)))
  97       dir))))
  98
  99
 100
 101 (defun quit (&optional (code 0))
 102   "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
 103     #+allegro (excl:exit code :quiet t)
 104     #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
 105     #+(or cmu scl) (ext:quit code)
 106     #+cormanlisp (win32:exitprocess code)
 107     #+gcl (lisp:bye code)
 108     #+lispworks (lw:quit :status code)
 109     #+lucid (lcl:quit code)
 110     #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
 111     #+mcl (ccl:quit code)
 112     #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
 113     (error 'not-implemented :proc (list 'quit code)))
 114
 115
 116 (defun command-line-arguments ()
 117   #+allegro (system:command-line-arguments)
 118   #+sbcl sb-ext:*posix-argv*
 119   )
 120
 121 (defun copy-file (from to &key link overwrite preserve-symbolic-links
 122                   (preserve-time t) remove-destination force verbose)
 123   #+allegro (sys:copy-file from to :link link :overwrite overwrite
 124                            :preserve-symbolic-links preserve-symbolic-links
 125                            :preserve-time preserve-time
 126                            :remove-destination remove-destination
 127                            :force force :verbose verbose)
 128   #-allegro
 129   (declare (ignore verbose preserve-symbolic-links overwrite))
 130   (cond
 131     ((and (typep from 'stream) (typep to 'stream))
 132      (copy-binary-stream from to))
 133     ((not (probe-file from))
 134      (error "File ~A does not exist." from))
 135     ((eq link :hard)
 136      (run-shell-command "ln -f ~A ~A" (namestring from) (namestring to)))
 137     (link
 138      (multiple-value-bind (stdout stderr status)
 139          (command-output "ln -f ~A ~A" (namestring from) (namestring to))
 140        (declare (ignore stdout stderr))
 141        ;; try symbolic if command failed
 142        (unless (zerop status)
 143          (run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to)))))
 144     (t
 145      (when (and (or force remove-destination) (probe-file to))
 146        (delete-file to))
 147      (let* ((options (if preserve-time
 148                          "-p"
 149                          ""))
 150             (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to))))
 151        (run-shell-command cmd)))))