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) (eq :directory (unix:unix-file-kind (namestring path)))
48 #+lispworks (lw:file-directory-p path)
49 #+sbcl (eq :directory (sb-unix:unix-file-kind (namestring path)))
50 #-(or allegro clisp cmu lispworks sbcl scl)
54 (defun cwd (&optional dir)
55 "Change directory and set default pathname"
58 (when (and (typep dir 'logical-pathname)
59 (translate-logical-pathname dir))
60 (setq dir (translate-logical-pathname dir)))
62 (setq dir (parse-namestring dir)))
63 #+allegro (excl:chdir dir)
64 #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
65 #+(or cmu scl) (setf (ext:default-directory) dir)
66 #+cormanlisp (ccl:set-current-directory dir)
67 #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
68 #+openmcl (ccl:cwd dir)
70 #+lispworks (hcl:change-directory dir)
71 (setq cl:*default-pathname-defaults* dir))
74 #+allegro (excl:current-directory)
75 #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
76 #+(or cmu scl) (ext:default-directory)
77 #+sbcl (sb-unix:posix-getcwd/)
78 #+cormanlisp (ccl:get-current-directory)
79 #+lispworks (hcl:get-working-directory)
80 #+mcl (ccl:mac-default-directory)
81 #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
83 (setq dir (parse-namestring dir)))
88 (defun quit (&optional (code 0))
89 "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
90 #+allegro (excl:exit code :quiet t)
91 #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
92 #+(or cmu scl) (ext:quit code)
93 #+cormanlisp (win32:exitprocess code)
95 #+lispworks (lw:quit :status code)
96 #+lucid (lcl:quit code)
97 #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
99 #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
100 (error 'not-implemented :proc (list 'quit code)))
103 (defun command-line-arguments ()
104 #+allegro (system:command-line-arguments)
105 #+sbcl sb-ext:*posix-argv*
108 (defun shell-command-output (cmd &key directory whole)
109 #+allegro (excl.osi:command-output cmd :directory directory :whole whole)
111 (let* ((out (make-array '(0) :element-type 'base-char :fill-pointer 0
113 (err (make-array '(0) :element-type 'base-char :fill-pointer 0
116 (sb-impl::process-exit-code
117 (with-output-to-string (out-stream out)
118 (with-output-to-string (err-stream err)
122 :input nil :output out-stream :error err-stream))))))
123 (values out err status))