From 6f333885c716800cf85c2986a3b835efe0e54e70 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 10 Sep 2003 12:56:02 +0000 Subject: [PATCH] r7814: add implementation-dependent file, new impl-dependent commands --- impl.lisp | 124 +++++++++++++++++++++++++++++++++++++++++++++++++++ io.lisp | 34 -------------- kmrcl.asd | 3 +- package.lisp | 10 ++++- 4 files changed, 134 insertions(+), 37 deletions(-) create mode 100644 impl.lisp diff --git a/impl.lisp b/impl.lisp new file mode 100644 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 68a6bc2..4dea295 100644 --- 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 7e43abc..c63818b 100644 --- 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 5d4bcc8..63198e7 100644 --- 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 -- 2.34.1