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)
54 #+sbcl (when (eq :directory
55 (sb-unix:unix-file-kind (namestring path)))
57 #-(or allegro clisp cmu lispworks sbcl scl)
61 (when error-if-does-not-exist
62 (error "Directory ~A does not exist." filename)))))
64 (defun cwd (&optional dir)
65 "Change directory and set default pathname"
68 (when (and (typep dir 'logical-pathname)
69 (translate-logical-pathname dir))
70 (setq dir (translate-logical-pathname dir)))
72 (setq dir (parse-namestring dir)))
73 #+allegro (excl:chdir dir)
74 #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
75 #+(or cmu scl) (setf (ext:default-directory) dir)
76 #+cormanlisp (ccl:set-current-directory dir)
77 #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
78 #+openmcl (ccl:cwd dir)
80 #+lispworks (hcl:change-directory dir)
81 (setq cl:*default-pathname-defaults* dir))
84 #+allegro (excl:current-directory)
85 #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
86 #+(or cmu scl) (ext:default-directory)
87 #+sbcl (sb-unix:posix-getcwd/)
88 #+cormanlisp (ccl:get-current-directory)
89 #+lispworks (hcl:get-working-directory)
90 #+mcl (ccl:mac-default-directory)
91 #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
93 (setq dir (parse-namestring dir)))
98 (defun quit (&optional (code 0))
99 "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
100 #+allegro (excl:exit code :quiet t)
101 #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
102 #+(or cmu scl) (ext:quit code)
103 #+cormanlisp (win32:exitprocess code)
104 #+gcl (lisp:bye code)
105 #+lispworks (lw:quit :status code)
106 #+lucid (lcl:quit code)
107 #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
108 #+mcl (ccl:quit code)
109 #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
110 (error 'not-implemented :proc (list 'quit code)))
113 (defun command-line-arguments ()
114 #+allegro (system:command-line-arguments)
115 #+sbcl sb-ext:*posix-argv*
118 (defun copy-file (from to &key link overwrite preserve-symbolic-links
119 (preserve-time t) remove-destination force verbose)
120 #+allegro (sys:copy-file from to :link link :overwrite overwrite
121 :preserve-symbolic-links preserve-symbolic-links
122 :preserve-time preserve-time
123 :remove-destination remove-destination
124 :force force :verbose verbose)
127 ((and (typep from 'stream) (typep to 'stream))
128 (copy-binary-stream from to))
129 ((not (probe-file from))
130 (error "File ~A does not exist." from))
132 (run-shell-command "ln -f ~A ~A" (namestring from) (namestring to)))
134 (multiple-value-bind (stdout stderr status)
135 (command-output "ln -f ~A ~A" (namestring from) (namestring to))
136 (declare (ignore stdout stderr))
137 ;; try symbolic if command failed
138 (unless (zerop status)
139 (run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to)))))
141 (when (and (or force remove-destination) (probe-file to))
143 (let* ((options (if preserve-time
146 (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to))))
147 (run-shell-command cmd)))))