;-*- Mode: Common-lisp; Package: ytools; -*-
(in-package :ytools)

;;; $Id: ytools.lsy,v 2.6 2006/08/04 14:08:07 airfoyle Exp $

;;; Copyright (C) 1976-2005
;;;     Drew McDermott and Yale University.  All rights reserved
;;; This software is released under the terms of the Modified BSD
;;; License.  See file COPYING for details.

(defparameter ytools-package* (find-package :ytools))
(defparameter lisp-package* (find-package :common-lisp))
(defparameter cl-user-package* (find-package :common-lisp-user))

(declaim (special lisp-object-extn* lisp-source-extn*))

(push ':newfangled *features*)

#-excl
(eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar readtable-table*
           (list (list ':lisp lisp-readtable*)
		 (list ':ytools ytools-readtable*)))
   (defun named-readtable (name &optional errorp)
      (setq name (intern (symbol-name name) :keyword))
      (let ((e (assoc name readtable-table*)))
	 (cond (e (cadr e))
	       (errorp
		(error "There is no readtable named ~s" name))
	       (t nil))))
   (defun (setf named-readtable) (rt name &optional errorp)
      (declare (ignore errorp))
      (setq name (intern (symbol-name name) :keyword))
      (let ((e (assoc name readtable-table*)))
	 (cond ((not e)
		(setq e (list name nil))
		(setq readtable-table*
		      (cons e readtable-table*))))
	 (setf (cadr e) rt)
	 rt)))

#+excl
(eval-when (:compile-toplevel :load-toplevel :execute)
   (import 'excl:named-readtable))

(setf (named-readtable ':ytools) ytools-readtable*)

(defparameter ytools-core-files*
    '("base" "util" "datafun" "chunk" "pathname" "slurp"
      "files" "fload" "depend" "module"))

(cond ((and (boundp 'subst-core-files*)
	    subst-core-files*)
       (setq ytools-core-files*
	     (subst "files-new" "files" ytools-core-files*
		    :test #'equal))))

(defparameter bin-idio-dir*
   (cond ((equal bin-idio* "")
	  '())
	 (t
	  (let ((pn (parse-namestring bin-idio*)))
	     (let ((dir (pathname-directory pn)))
		(cond ((and (consp dir)
			    (eq (car dir) ':relative))
		       (cdr dir))
		      (t
		       (cerror "I will assume there is no special bin subdirectory for this Lisp"
			       "Illegal as bin subdirectory: ~s"
			       bin-idio*)
		       '())))))))

(defparameter ytools-bin-relative*
              (append (pathname-directory (parse-namestring ytools-bin-path*))
		      (cond ((string= bin-idio* "") '())
			    (t (cdr (pathname-directory (parse-namestring bin-idio*)))))
		      '("ytools")))

;;;;	     '(:relative :back "bin" "ytools")

(defparameter dir-delim*
     (cond ((= (length ytools::directory-delimiter*)
	       1)
	    (elt ytools::directory-delimiter* 0))
	   (t
	    (error "YTools requires directory-delimiter to be ~
                    exactly one character, not ~s"
		  ytools::directory-delimiter*))))


;;;;(defparameter ytools-home-dir* "~/CVSified/prog/ytools/")
;;;;(defparameter lisp-object-extn* "fasl")

(defparameter ytools-dir-pathname*
              (parse-namestring ytools-home-dir*))

(defun place-relative-pathname (pn dir-list suff ensure-existence)
   (cond ((stringp dir-list)
	  (setq dir-list (pathname-directory (parse-namestring dir-list)))))
   (cond ((not (listp dir-list))
	  (error "place-relative-pathname can't handle directory: ~s~%"
		 dir-list)))
   (cond ((eq (car dir-list) ':relative)
	  (setq dir-list (cdr dir-list)))
	 (t
	  (error "Unsuitable for specifying relative pathname: ~s"
		 dir-list)))
   (let ((start (pathname-directory pn)))
      (cond ((and (consp start) (eq (car start) ':absolute))
	     (let ((above-dirs (reverse (cdr start)))
		   (below-dirs '())
		   (from-dir-list '()))
	        ;; We use 'dir-list' as a set of instructions for arriving
		;; at a relative directory.
	        ;; As we go, the three variables above represent the
	        ;; directories traversed so far, leaving us in the "current
	        ;; directory."
		;; 'above-dirs' is list (in ascending order) of directories
	        ;; above (and including) the current dir.
	        ;; 'below-dirs' is list (in descending order)
	        ;; of directories we passed on the way up to current dir.
	        ;; 'from-dir-list' is a list (in ascending order) of
	        ;; directories copied from 'dir-list'.
		(dolist (d dir-list)
		   (cond ((eq d ':relative)
			  (error "relative! dir-list = ~s" dir-list)))
;;;;		   (format t "above-dirs = ~s from-dir-list = ~s d = ~s below-dirs = ~s~%"
;;;;			   above-dirs from-dir-list d below-dirs)
		   (cond ((or (member d '(:back :up)) (equal d ".."))
			  (cond ((null from-dir-list)
				 ;; Go up one layer, recording in 'below-dirs'
				 ;; the directory passed.--
				 (cond ((null above-dirs)
					(error "Relative directory ~s undefined wrt ~s"
					       dir-list pn))
				       (t
					(push (pop above-dirs) below-dirs))))
			      ;; But once we've started recording
			      ;; directories in 'from-dir-list', a
			      ;; ".." directory is a puzzle. --
				((null above-dirs)
				 ;; We either go up and leave
				 ;; 'from-dir-list' alone, or, if we
				 ;; can't go up, we interpret ".." as
				 ;; perversely instructing us to undo
				 ;; the last addition to
				 ;; 'from-dir-list' --
				 (pop from-dir-list))
				(t
				 ;; This is the case where we can 
				 ;; go up (pop 'above-dirs') and leave
				 ;; 'from-dir-list' and 'below-dirs'
				 ;; alone --
				 (pop above-dirs))))
			 ((member d '(-- "--") :test #'equal)
			  ;; Special flag that means *don't* record in
			  ;; 'below-dirs' the last layer we passed.
			  ;; This makes sense only if this layer does
			  ;; not help discriminate subdirectories.
			  ;; Useful for purging "src" layers from "bin"
			  ;; directories (assuming *all* "bin"
			  ;; subdirectories come from "src"
			  ;; subdirectories).--
			  (pop below-dirs))
			 (t
			  ;; A normal directory gets copied to
			  ;; 'from-dir-list' --
			  (push d from-dir-list))))
;;;;		(format t "above-dirs = ~s~%from-dir-list = ~s~%below-dirs = ~s~%"
;;;;			above-dirs from-dir-list below-dirs)
;;;;		(setq above* above-dirs from* from-dir-list below* below-dirs)
		(let ((res-pn
		          (make-pathname
			      :directory
			         `(:absolute ,@(reverse above-dirs)
					     ,@(reverse from-dir-list)
					     ,@below-dirs)
			      :type suff)))
		   (cond (ensure-existence
			  (ensure-directories-exist res-pn)))
		   res-pn)))
	    (t
	     (error "Can't take relative directory with respect to relative directory ~s"
		    pn)))))

(defparameter ytools-bin-dir-pathname*
   (let ((bin-dir-list 
            (append (pathname-directory (pathname ytools-bin-path*))
                    (cond ((string= bin-idio* "") '())
                          (t (cdr (pathname-directory
                                     (parse-namestring bin-idio*))))))))
      (cond ((eq (car bin-dir-list)
                 ':absolute)
             (merge-pathnames
                (make-pathname
                   :directory bin-dir-list
                   :type lisp-object-extn*)
                ytools-dir-pathname*))
            (t
             (place-relative-pathname
                (pathname ytools-dir-pathname*)
                bin-dir-list
                lisp-object-extn*
                t)))))

;;;;(setq *features* (adjoin ':pre-chunk *features*))

(cl:defun load-core ()
      (dolist (bf ytools-core-files*)
	 (load (merge-pathnames
		  (make-pathname :name bf :type lisp-object-extn*)
		  ytools-bin-dir-pathname*)))
;;;;      (format t "Before loading ytinit, config-directory* = ~s~%"
;;;;	      config-directory*)
)
     
(cl:defun compile-core ()
   (dolist (bf ytools-core-files*)
      (let ((lisp-file
	       (merge-pathnames
		  (make-pathname :name bf :type "lisp")
		  ytools-dir-pathname*))
	    (fasl-file
	       (ensure-directories-exist
		  (merge-pathnames
		     (make-pathname :name bf :type lisp-object-extn*)
		     ytools-bin-dir-pathname*))))
	 (compile-file lisp-file :output-file fasl-file)
	 (load fasl-file))))

(cl:defun delete-core-files ()
   (dolist (bf ytools-core-files*)
      (let ((fasl-file
	       (ensure-directories-exist
		  (merge-pathnames
		     (make-pathname :name bf :type lisp-object-extn*)
		     ytools-bin-dir-pathname*))))
         (cond ((probe-file fasl-file)
;;;;                (out "Pretending to delete " fasl-file :%)
                (delete-file fasl-file))))))
     
(cl:defun use-ytools (&optional (pkg *package*))
   (shadowing-import '(ytools::defun ytools::defmacro
                       ytools::defmethod ytools::eval-when)
		     pkg)
   (use-package :ytools pkg))

(eval-when (:load-toplevel :execute)
  (export '(use-ytools named-readtable in-ytools
            lisp-package* lisp-readtable* ytools-package* ytools-readtable*
            revnum-from-changelog version-num-from-changelog)))

(setq *features* (adjoin ':ytools *features*))

(shadowing-import 'ytools :cl-user)

(defun in-ytools ()
   (setq *readtable* ytools-readtable*)
   (in-package :ytools))

(defparameter +ytools-version+
     ;;;; "2.1.9c"
    (version-num-from-changelog ytools-home-dir*)
    )