1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: impl.lisp
;;;; Purpose: Implementation Dependent routines for kmrcl
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Sep 2003
;;;;
;;;; $Id: impl.lisp 8573 2004-01-29 23:30:50Z kevin $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:kmrcl)
(defun canonicalize-directory-name (filename)
(flet ((un-unspecific (value)
(if (eq value :unspecific) nil value)))
(let* ((path (pathname filename))
(name (un-unspecific (pathname-name path)))
(type (un-unspecific (pathname-type path)))
(new-dir
(cond ((and name type) (list (concatenate 'string name "." type)))
(name (list name))
(type (list type))
(t nil))))
(if new-dir
(make-pathname
:directory (append (un-unspecific (pathname-directory path))
new-dir)
:name nil :type nil :version nil :defaults path)
path))))
(defun probe-directory (filename)
(let ((path (canonicalize-directory-name filename)))
#+allegro (excl:probe-directory path)
#+clisp (values
(ignore-errors
(#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
path)))
#+(or cmu scl) (eq :directory (unix:unix-file-kind (namestring path)))
#+lispworks (lw:file-directory-p path)
#+sbcl (eq :directory (sb-unix:unix-file-kind (namestring path)))
#-(or allegro clisp cmu lispworks sbcl scl)
(probe-file path)))
(defun cwd (&optional dir)
"Change directory and set default pathname"
(cond
((not (null dir))
(when (and (typep dir 'logical-pathname)
(translate-logical-pathname dir))
(setq dir (translate-logical-pathname dir)))
(when (stringp dir)
(setq dir (parse-namestring dir)))
#+allegro (excl:chdir dir)
#+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
#+(or cmu scl) (setf (ext:default-directory) dir)
#+cormanlisp (ccl:set-current-directory dir)
#+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
#+openmcl (ccl:cwd dir)
#+gcl (si:chdir dir)
#+lispworks (hcl:change-directory dir)
(setq cl:*default-pathname-defaults* dir))
(t
(let ((dir
#+allegro (excl:current-directory)
#+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
#+(or cmu scl) (ext:default-directory)
#+sbcl (sb-unix:posix-getcwd/)
#+cormanlisp (ccl:get-current-directory)
#+lispworks (hcl:get-working-directory)
#+mcl (ccl:mac-default-directory)
#-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
(when (stringp dir)
(setq dir (parse-namestring dir)))
dir))))
(defun quit (&optional (code 0))
"Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
#+allegro (excl:exit code :quiet t)
#+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
#+(or cmu scl) (ext:quit code)
#+cormanlisp (win32:exitprocess code)
#+gcl (lisp:bye code)
#+lispworks (lw:quit :status code)
#+lucid (lcl:quit code)
#+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
#+mcl (ccl:quit code)
#-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
(error 'not-implemented :proc (list 'quit code)))
(defun command-line-arguments ()
#+allegro (system:command-line-arguments)
#+sbcl sb-ext:*posix-argv*
)
(defun shell-command-output (cmd &key directory whole)
#+allegro (excl.osi:command-output cmd :directory directory :whole whole)
#+sbcl
(let* ((out (make-array '(0) :element-type 'base-char :fill-pointer 0
:adjustable t))
(err (make-array '(0) :element-type 'base-char :fill-pointer 0
:adjustable t))
(status
(sb-impl::process-exit-code
(with-output-to-string (out-stream out)
(with-output-to-string (err-stream err)
(sb-ext:run-program
"/bin/sh"
(list "-c" cmd)
:input nil :output out-stream :error err-stream))))))
(values out err status))
)
|