;;;; -*- 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$
;;;;
;;;; 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))
  )