;;; -*- Mode:Lisp; Syntax:Common-Lisp; Package:COMMON-LISP -*-
;;; -----------------------------------------------------------------------
;;; File:         CLISP-init.lisp
;;; Description:  Init file for CLISP
;;;               Redef. of load, require and cd to
;;;               expand environment variables.
;;; Author:       Tom Breton (But large parts are borrowed from other files)
;;; Created:      1999-04-15
;;; Modified:     
;;; -----------------------------------------------------------------------

;; Commentary:
;;
;; Please pardon any weaknesses in this file.  This is my first LISP
;; project (as opposed to emacs-lisp) - Tom

(provide "CLISP-init")

;;; Make all the functions visible in all packages
(in-package 'common-lisp)

;;;;;;;;;;
;;Declare exports
(export '(Tehom-setenv Tehom-getenv load require probe-file cd expand-name))

;;;;;;;;;;
;;Definitions for CLISP+FUF

;;Make CLISP accept the ".l" extension FUF uses.
(pushnew
  (make-pathname :type "l")
  SYSTEM::*SOURCE-FILE-TYPES*
  :test #'equal)

;;;;;;
;;Some definitions to make the rest of the file more portable

(defmacro Tehom-MUFFLE-CERRORS (&rest body)
  "Forwarding macro for CLISP's MUFFLE-CERRORS"
    `(MUFFLE-CERRORS ,@body ) )


(defun Tehom-sys-getenv (str)
  "Forwarding function for CLISP's GETENV"
  (SYSTEM::GETENV str))

;;;;;;;;;;;;;
;For systems where no setenv exists:

;;I am not sure whether these should overwrite the regular getenv, so
;;I will name them in a conservative way.
(defvar *shell-environ* nil "Private cache of shell environment")

(defun Tehom-setenv (var val)
  (pushnew (cons var val) *shell-environ* :test #'equal))

(defun Tehom-getenv (str)
  "Get an environment variable, looking first in the private cache of
shell environment."

  (or 
    (cdr 
      (assoc str *shell-environ* 
	:test #'string=))
    (Tehom-sys-getenv str))) 

;;;;;;;;;;;;;
;Simpler version, for systems where setenv exists
;
;(defun Tehom-getenv (str) 
;  "Get an environment variable"
;  (Tehom-sys-getenv str))
;;;;;;;;;;;;;


;;;;;;;;;;;;;
;;Code to expand variables.  It would be nice to share this across
;;Lisp implementations and depend only on the defines given above.

;;This behavior doesn't seem to agree with the doc string, wrt
;;returning nil on failure.  I didn't change it from where I copied it
;;because I'm new at LISP, but it looks suspicious - Tom
(defun environment-p (string)
  "nil if string is not an environment variable.
       if it is, returns its value."
  (when (and (stringp string) (> (length string) 0) (eql (char string 0) #\$))
    (let ((value (Tehom-getenv (subseq string 1))))
      (if value value string))))

(defun home-dir-p (string)
  "nil if string is not a home dir segment in a pathname.
       if it is, returns the form (:HOME-DIR name)"
  (cond 
    ((and (listp string) (eq :home-dir (car string))) string)
    ((equal string "") nil)
    ((and (stringp string) (eql (char string 0) #\~))
      (list :home-dir (subseq string 1)))
    (t nil)))


(defun expand-dir (dir-in dir-out &aux value)
  "Expand all segments that need to be expanded. 
       Takes care of // and ~ business.
       dir-in is in the form of the output of pathname-dir.
       dir-out is the result (nil when first called)."
  (cond 
    ((null dir-in) (nreverse dir-out))
    ((equal (car dir-in) "")		; case of "//"
      (expand-dir (cdr dir-in) nil))
    ((setq value (home-dir-p (car dir-in))) ; case of "~"
      (expand-dir (cdr dir-in) (list value))) 
    ((setq value (environment-p (car dir-in))) ; case of "$"
      (let ((expanded (pathname-directory 
			(concatenate 'string value "/"))))
	(cond ((eq :relative (car expanded))
		(expand-dir (cdr dir-in) (append (reverse (cdr expanded))
					   dir-out)))
	  (t;; expanded dir is absolute
	    (expand-dir (cdr dir-in) (reverse expanded))))))
    (t (expand-dir (cdr dir-in) (cons (car dir-in) dir-out)))

    ))


(defun expand-name (filename)
  "Expand shell environment variables in file names"
  (setq filename (namestring filename))
  (cond	
    ;;It's blank (so avoid trying to examine "the last character")
    ((equal filename "") "")

    ;;it's a dir
    ((eql (char filename (1- (length filename))) #\/) 
      (namestring
	(make-pathname :directory 
	  (expand-dir (pathname-directory filename) nil))))

    ;;it's a file
    (t 
      (let 
	((dir 
	   (expand-dir 
	     (pathname-directory 
	       (concatenate 'string filename "/")) nil)))
	(namestring
	  (make-pathname
	    :directory (butlast dir)
	    :name (car (last dir))
	    ))))))


;;;;;;;;;;
;;Save the old functions

(unless (fboundp 'old-load)
  (setf (symbol-function 'old-load) (symbol-function 'load)))
(unless (fboundp 'old-require)
  (setf (symbol-function 'old-require) (symbol-function 'require)))
(unless (fboundp 'old-probe-file)
  (setf (symbol-function 'old-probe-file) (symbol-function 'probe-file)))
(unless (fboundp 'old-cd)
  (setf (symbol-function 'old-cd) (symbol-function 'cd)))

(unless (fboundp 'old-compile-require)
  (setf (symbol-function 'old-compile-require) 
    (symbol-function 'SYSTEM::C-REQUIRE)))

;;;;;;;;;;
;;Redefine crucial functions to use expand-name.

;;We're going to get continuable errors because we redefine stuff.
;;They are unavoidable, so we muffle them.
(Tehom-MUFFLE-CERRORS

  (defun load (name &rest args)
    (let ((name (expand-name name)))
      (apply 'common-lisp::old-load (cons  name args))))

  (defun require (module &optional (file module))
    (funcall 'common-lisp::old-require module (expand-name file)))

  ;;provide does not have to be redefined too, because the parm it
  ;;shares with require is not expanded or otherwise modified.

  (defun probe-file (filename)
    (funcall 'common-lisp::old-probe-file (expand-name filename)))

  ;;I don't see why this one is written differently, without funcall,
  ;;but I've copied it as is anyways - Tom
  (defun cd (string)
    (common-lisp::old-cd (expand-name string)))

  ;;This is required for CLISP, because the compile deals with require
  ;;separately from the interpreter.  It is not neccessary for other
  ;;LISP systems, AFAIK - Tom
  (defun SYSTEM::C-REQUIRE (module &optional (file module))
    (funcall 'common-lisp::old-compile-require module (expand-name file)))

  ) ;;End of Tehom-MUFFLE-CERRORS


;;; CLISP-init.lisp ends here.