1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Implementation Dependent routines for kmrcl
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Sep 2003
10 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
12 ;;;; KMRCL users are granted the rights to distribute and use this software
13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
15 ;;;; *************************************************************************
19 (defun canonicalize-directory-name (filename)
20 (flet ((un-unspecific (value)
21 (if (eq value :unspecific) nil value)))
22 (let* ((path (pathname filename))
23 (name (un-unspecific (pathname-name path)))
24 (type (un-unspecific (pathname-type path)))
26 (cond ((and name type) (list (concatenate 'string name "." type)))
32 :directory (append (un-unspecific (pathname-directory path))
34 :name nil :type nil :version nil :defaults path)
38 (defun probe-directory (filename &key (error-if-does-not-exist nil))
39 (let* ((path (canonicalize-directory-name filename))
41 #+allegro (excl:probe-directory path)
44 (#+lisp=cl ext:probe-directory
45 #-lisp=cl lisp:probe-directory
47 #+(or cmu scl) (when (eq :directory
48 (unix:unix-file-kind (namestring path)))
50 #+lispworks (when (lw:file-directory-p path)
54 (or (find-symbol "NATIVE-FILE-KIND" :sb-impl)
55 (find-symbol "UNIX-FILE-KIND" :sb-unix))))
56 (when (eq :directory (funcall file-kind-fun (namestring path)))
58 #-(or allegro clisp cmu lispworks sbcl scl)
62 (when error-if-does-not-exist
63 (error "Directory ~A does not exist." filename)))))
65 (defun cwd (&optional dir)
66 "Change directory and set default pathname"
69 (when (and (typep dir 'logical-pathname)
70 (translate-logical-pathname dir))
71 (setq dir (translate-logical-pathname dir)))
73 (setq dir (parse-namestring dir)))
74 #+allegro (excl:chdir dir)
75 #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
76 #+(or cmu scl) (setf (ext:default-directory) dir)
77 #+cormanlisp (ccl:set-current-directory dir)
78 #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
79 #+openmcl (ccl:cwd dir)
81 #+lispworks (hcl:change-directory dir)
82 (setq cl:*default-pathname-defaults* dir))
85 #+allegro (excl:current-directory)
86 #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
87 #+(or cmu scl) (ext:default-directory)
88 #+sbcl (sb-unix:posix-getcwd/)
89 #+cormanlisp (ccl:get-current-directory)
90 #+lispworks (hcl:get-working-directory)
91 #+mcl (ccl:mac-default-directory)
92 #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
94 (setq dir (parse-namestring dir)))
99 (defun quit (&optional (code 0))
100 "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
101 #+allegro (excl:exit code :quiet t)
102 #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
103 #+(or cmu scl) (ext:quit code)
104 #+cormanlisp (win32:exitprocess code)
105 #+gcl (lisp:bye code)
106 #+lispworks (lw:quit :status code)
107 #+lucid (lcl:quit code)
108 #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
109 #+mcl (ccl:quit code)
110 #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
111 (error 'not-implemented :proc (list 'quit code)))
114 (defun command-line-arguments ()
115 #+allegro (system:command-line-arguments)
116 #+sbcl sb-ext:*posix-argv*
119 (defun copy-file (from to &key link overwrite preserve-symbolic-links
120 (preserve-time t) remove-destination force verbose)
121 #+allegro (sys:copy-file from to :link link :overwrite overwrite
122 :preserve-symbolic-links preserve-symbolic-links
123 :preserve-time preserve-time
124 :remove-destination remove-destination
125 :force force :verbose verbose)
127 (declare (ignore verbose preserve-symbolic-links overwrite))
129 ((and (typep from 'stream) (typep to 'stream))
130 (copy-binary-stream from to))
131 ((not (probe-file from))
132 (error "File ~A does not exist." from))
134 (run-shell-command "ln -f ~A ~A" (namestring from) (namestring to)))
136 (multiple-value-bind (stdout stderr status)
137 (command-output "ln -f ~A ~A" (namestring from) (namestring to))
138 (declare (ignore stdout stderr))
139 ;; try symbolic if command failed
140 (unless (zerop status)
141 (run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to)))))
143 (when (and (or force remove-destination) (probe-file to))
145 (let* ((options (if preserve-time
148 (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to))))
149 (run-shell-command cmd)))))