r7814: add implementation-dependent file, new impl-dependent commands

diff --git a/impl.lisp b/impl.lisp
new file mode 100644 (file)
index 0000000..c6aa65d
--- /dev/null
+++ b/impl.lisp
@@ -0,0 +1,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: io.lisp 7795 2003-09-10 05:44:47Z 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))
+  )

diff --git a/io.lisp b/io.lisp
index 68a6bc23cd9a8ab956d6f19ebc3db815d0870f61..4dea295f5e789d6dacb1c2eb86fe99c155d71487 100644 (file)
--- a/io.lisp
+++ b/io.lisp
@@ -191,40 +191,6 @@
     (open-device-stream #p"/dev/null" :output))  
   )
 
-(defun un-unspecific (value)
-  "Convert :UNSPECIFIC to NIL."
-  (if (eq value :unspecific) nil value))
-
-(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 directory-tree (filename)
   "Returns a tree of pathnames for sub-directories of a directory"

diff --git a/kmrcl.asd b/kmrcl.asd
index 7e43abc2926f1cbfb7b4c59e874735d5b0f03106..c63818b4e4c66f15d49b9c66f1f42e2aa682ddbd 100644 (file)
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -38,7 +38,8 @@
      (:file "functions" :depends-on ("macros"))
      (:file "lists" :depends-on ("macros"))
      (:file "seqs" :depends-on ("macros"))
-     (:file "io" :depends-on ("macros"))
+     (:file "impl" :depends-on ("macros")) 
+     (:file "io" :depends-on ("macros" "impl"))
      (:file "console" :depends-on ("macros"))
      (:file "strings" :depends-on ("macros" "seqs"))
      (:file "strmatch" :depends-on ("strings"))

diff --git a/package.lisp b/package.lisp
index 5d4bcc80d3002554ffaa24b68a90b0c251e7162c..63198e7855fbfb9c41aa528f9f24f8bd1cbcfb34 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -81,9 +81,15 @@
    #:file-subst
    #:stream-subst
    #:null-output-stream
-   #:probe-directory
    #:directory-tree
-   
+
+   ;; impl.lisp
+   #:probe-directory
+   #:cwd
+   #:quit
+   #:command-line-arguments
+   #:shell-command-output
+
    ;; lists.lisp
    #:remove-from-tree-if
    #:find-tree