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
12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
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 ;;;; *************************************************************************
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)))
28 (cond ((and name type) (list (concatenate 'string name "." type)))
34 :directory (append (un-unspecific (pathname-directory path))
36 :name nil :type nil :version nil :defaults path)
40 (defun probe-directory (filename &key (error-if-does-not-exist nil))
41 (let* ((path (canonicalize-directory-name filename))
43 #+allegro (excl:probe-directory path)
46 (#+lisp=cl ext:probe-directory
47 #-lisp=cl lisp:probe-directory
49 #+(or cmu scl) (when (eq :directory
50 (unix:unix-file-kind (namestring path)))
52 #+lispworks (when (lw:file-directory-p path)
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)))
60 #-(or allegro clisp cmu lispworks sbcl scl)
64 (when error-if-does-not-exist
65 (error "Directory ~A does not exist." filename)))))
67 (defun cwd (&optional dir)
68 "Change directory and set default pathname"
71 (when (and (typep dir 'logical-pathname)
72 (translate-logical-pathname dir))
73 (setq dir (translate-logical-pathname 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)
83 #+lispworks (hcl:change-directory dir)
84 (setq cl:*default-pathname-defaults* 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 ".")))
96 (setq dir (parse-namestring dir)))
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)))
116 (defun command-line-arguments ()
117 #+allegro (system:command-line-arguments)
118 #+sbcl sb-ext:*posix-argv*
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)
129 (declare (ignore verbose preserve-symbolic-links overwrite))
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))
136 (run-shell-command "ln -f ~A ~A" (namestring from) (namestring to)))
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)))))
145 (when (and (or force remove-destination) (probe-file to))
147 (let* ((options (if preserve-time
150 (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to))))
151 (run-shell-command cmd)))))