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)
41 (let ((path (canonicalize-directory-name filename)))
42 #+allegro (excl:probe-directory path)
45 (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
47 #+(or cmu scl) (when (eq :directory (unix:unix-file-kind (namestring path)))
49 #+lispworks (when (lw:file-directory-p path)
51 #+sbcl (when (eq :directory (sb-unix:unix-file-kind (namestring path)))
53 #-(or allegro clisp cmu lispworks sbcl scl)
57 (defun cwd (&optional dir)
58 "Change directory and set default pathname"
61 (when (and (typep dir 'logical-pathname)
62 (translate-logical-pathname dir))
63 (setq dir (translate-logical-pathname dir)))
65 (setq dir (parse-namestring dir)))
66 #+allegro (excl:chdir dir)
67 #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
68 #+(or cmu scl) (setf (ext:default-directory) dir)
69 #+cormanlisp (ccl:set-current-directory dir)
70 #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
71 #+openmcl (ccl:cwd dir)
73 #+lispworks (hcl:change-directory dir)
74 (setq cl:*default-pathname-defaults* dir))
77 #+allegro (excl:current-directory)
78 #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
79 #+(or cmu scl) (ext:default-directory)
80 #+sbcl (sb-unix:posix-getcwd/)
81 #+cormanlisp (ccl:get-current-directory)
82 #+lispworks (hcl:get-working-directory)
83 #+mcl (ccl:mac-default-directory)
84 #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
86 (setq dir (parse-namestring dir)))
91 (defun quit (&optional (code 0))
92 "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
93 #+allegro (excl:exit code :quiet t)
94 #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
95 #+(or cmu scl) (ext:quit code)
96 #+cormanlisp (win32:exitprocess code)
98 #+lispworks (lw:quit :status code)
99 #+lucid (lcl:quit code)
100 #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
101 #+mcl (ccl:quit code)
102 #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
103 (error 'not-implemented :proc (list 'quit code)))
106 (defun command-line-arguments ()
107 #+allegro (system:command-line-arguments)
108 #+sbcl sb-ext:*posix-argv*
111 (defun copy-file (from to &key link overwrite preserve-symbolic-links
112 (preserve-time t) remove-destination force verbose)
113 #+allegro (sys:copy-file from to :link link :overwrite overwrite
114 :preserve-symbolic-links preserve-symbolic-links
115 :preserve-time preserve-time
116 :remove-destination remove-destination
117 :force force :verbose verbose)
120 ((and (typep from 'stream) (typep to 'stream))
121 (copy-binary-stream from to))
122 ((not (probe-file from))
123 (error "File ~A does not exist." from))
125 (run-shell-command "ln -f ~A ~A" (namestring from) (namestring to)))
127 (multiple-value-bind (stdout stderr status)
128 (command-output "ln -f ~A ~A" (namestring from) (namestring to))
129 (declare (ignore stdout stderr))
130 ;; try symbolic if command failed
131 (unless (zerop status)
132 (run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to)))))
134 (when (and (or force remove-destination) (probe-file to))
136 (let* ((options (if preserve-time
139 (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to))))
140 (run-shell-command cmd)))))