(in-package "COMMON-LISP-USER")

;;; File: version-utilities.lisp
;;;
;;; Defines the :version-case macro for conditionalizing across
;;; ranges (possibly open) of Lisp versions. Based on utilities 
;;; adapted from Knut Hartmann's original attack on `versionitis', caused
;;; previously whenever moving KPML to a new release of some Lisp. Errors
;;; were introduced by conditionalizations not knowing about the new
;;; Lisp version and so code would not compile, or compile wrongly. This
;;; is now handled by allowing version conditionalization to succeed
;;; whenever a used Lisp version is greater than some given version. 
;;; Reconditionalization then only has to be done in the case that the
;;; newer Lisp version indeed has some different behaviour/requirements
;;; to the former versions. Ranges within which some conditionalization
;;; should apply are also possible. 
;;;
;;; This file needs to be loaded before any conditionalizations using
;;; it occur, which is more or less immediately since both compile/load-kpml
;;; and cond-defsystem.lisp have relevant conditionalizations in them.
;;; So we add its load to KPML-INSTALLATION.
;;;
;;; It is strongly assumed that newer version numbers are pushed
;;; onto the front of the *features* list, that is, numbers should be
;;; strictly decreasing. If any Lisp release does not follow this
;;; strategy then there will need to be a change so that we find all
;;; matching version ids and take the highest.
;;; 
;;; John, Feb99, Stirling.
;;;       Apr99, Bremen (revised)
;;;       May99, Bremen (small addition to silence Lispworks complaints 
;;;                      about defining macros in the Keywords package)
;;;       Jul20, Bewmwn (silence warnings in Lispworks 7 as well)

;;; Introduced as standard in KPML 2.1
(defvar *locked-keyword-package* nil)

#+lispworks
(when (member "KEYWORD" CL-USER::*PACKAGES-FOR-WARN-ON-REDEFINITION*
              :test #'string=)
  (setf CL-USER::*PACKAGES-FOR-WARN-ON-REDEFINITION*
        (remove "KEYWORD" CL-USER::*PACKAGES-FOR-WARN-ON-REDEFINITION*
                :test #'string=))
  (setf *locked-keyword-package* T))
  
#+(and :lispworks :lispworks7)
(setf cl-user::*handle-warn-on-redefinition* nil)

;;; ----------------------------------------------------------------------
;;; From Knut almost as is...
;;; ordering made strict if desired.
;;;
;;; Examples:
;;;  (lexical-ordering-p '(4 3) '(4 3 1)) => nil
;;;  (lexical-ordering-p '(4 3 1) '(4 3)) => t
;;;  (lexical-ordering-p '(4 3) '(4 3)) => (not strict)   ** changed here **
;;;  (lexical-ordering-p '(4 3) '(4 2 1)) => t
;;;  (lexical-ordering-p '(5 0) '(4 3 1)) => t
;;; ----------------------------------------------------------------------

(defun LEXICAL-ORDERING-P (numberList1 numberList2 &optional (strict nil))
  (do* ((numbers1 numberList1 (rest numbers1))
	(numbers2 numberList2 (rest numbers2))
	(number1 (first numbers1) (first numbers1))
	(number2 (first numbers2) (first numbers2)))
      ((or (null number1) (null number2) (/= number1 number2))
       (cond
	;; List numberList2 is longer than numberList1
	;; but has an identical starting sequence
	((and strict (null number1) (null number2)) nil) ;; ** changed here **
	((null number2) t)
	((null number1) nil)
	((> number1 number2) t)
	((< number1 number2) nil)))))

;;; ----------------------------------------------------------------------
;;; From Knut as is...
;;;
;;; Examples:
;;;   (transform-versionstring "4.13.39.1") => (4 13 39 1)
;;;   (transform-versionstring "413") => (413)
;;;
;;; (Note: now also used in the KPML patch checking utilities...)
;;; ----------------------------------------------------------------------  

(defun TRANSFORM-VERSIONSTRING (string)
  (do* ((theString string)
	(numberList nil)
	(dotPosition (position #\. theString) (position #\. theString)))
      ((null dotPosition)
       (reverse (cons (read-from-string theString) numberList)))
    (push (read-from-string (subseq theString 0 dotPosition)) numberList)
    (setf theString (subseq theString (1+ dotPosition)))))
		  
;;; ----------------------------------------------------------------------
;;; From Knut almost as is... the main API function...
;;; added version-numbers-p tests so that the function is not tripped up by 
;;; unforeseen garbage coming in... Also test can now be strictly greater than
;;; or not because of change above.
;;;
;;; Examples:
;;;  when (member :ALLEGRO-V4.3.1 *features*)
;;;   (greater-version-p ":ALLEGRO-V" "4.3" 
;;;            :exclude (list ":ALLEGRO-VERSION>=")) => T
;;;   (greater-version-p ":ALLEGRO-V" "4.3.1") => T
;;;   (greater-version-p ":ALLEGRO-V" "4.3.1" :strict T) => nil
;;;
;;;  when (member :ALLEGRO-V5.0 *features*)
;;;   (greater-version-p ":ALLEGRO-V" "4.3" 
;;;            :exclude (list ":ALLEGRO-VERSION>=")) => T
;;; etc.
;;;
;;; N.B. in Knut's version the sought version identifier *must* be
;;; present, otherwise we just loop: feature
;;; or bug Knut? Standard use was therefore to place the entire thing
;;; inside an appropriate conditionalization, e.g., #+Loom etc.
;;; This is still OK, but here we also make sure that we *never* loop,
;;; if a version is not found, then we just return NIL.
;;; ----------------------------------------------------------------------
  
(defun GREATER-VERSION-P 
    (string versionString &key (exclude nil)(strict nil))
  (let ((stringLength (length string)))
    (do* ((features *features* (rest features))
	  (feature (first features) (first features))
	  (featureString (write-to-string feature) (write-to-string feature)))
	((and 
	  ;; KPML: run for cover if we run out of features...
	  (if feature T (return-from GREATER-VERSION-P nil))
	  (not (member featureString exclude :test #'string-equal))
	  (> (length featureString) stringLength)
	  (string= (subseq featureString 0 stringLength) string)
	  (version-numbers-p (subseq featureString stringLength)))
	 (lexical-ordering-p
	  (transform-versionstring (subseq featureString stringLength))
	  (transform-versionstring versionString)
	  strict)))))

;;; ----------------------------------------------------------------------
;;; Following are additional to Knut's functions. Whereas greater-version-p
;;; is a good primitive, we don't want its use to get compiled into our
;;; compiled installed system since it is an unwanted overhead: the
;;; lisp version will not generally change underneath a compiled file (and
;;; often cannot in anycase). So now we provide macros specifically to
;;; control which version is taken given the active version features.
;;;
;;; Example of use:
;;;  (:version-case (":CLIM-") 
;;;      ((- "2.0") "something before version 2.0")
;;;      (("2.0" "2.2") "something just for versions between 2.0 and 2.2")
;;;      ((+ "2.2") "something for any version after 2.2"))
;;;
;;; Exclude list can be used as with greater-version-p, e.g.,
;;;  (:version-case (":CLIM-" :exclude (list "CLIM-MOTIF")) ...)
;;;
;;; The first case that matches will be taken. A case condition of
;;; some symbol (e.g., T or otherwise) always matches and will be taken
;;; if no previous case matches. 
;;;
;;; A version range of a single version may be abbreviated thus:
;;;   (:version-case (":CLIM-") 
;;;      ("2.3" "something only for CLIM version 2.3"))
;;; ----------------------------------------------------------------------
  
(defmacro :VERSION-CASE ((version-id &key (exclude nil)) &rest cases)
  `(progn
     ,@(loop named SEARCH-CASES
	   for (case-condition . case) in cases
	   do
	     (typecase case-condition
	       (cons
		(case (first case-condition)
		  (- 
		   (when (not 
			  (greater-version-p 
			   version-id (second case-condition) 
			   :exclude exclude))
		     (return-from SEARCH-CASES case)))
		  (+
		   (when (greater-version-p 
			  version-id (second case-condition) 
			  :exclude exclude :strict T)
		     (return-from SEARCH-CASES case)))
		  (t
		   (if (and (greater-version-p 
			     version-id (first case-condition) 
			     :exclude exclude)
			    (not 
			     (greater-version-p 
			      version-id 
			      (second case-condition) 
			      :exclude exclude :strict T)))
		       (return-from SEARCH-CASES case)))))
	       (string
		(if (and (greater-version-p version-id case-condition 
					    :exclude exclude)
			 (not 
			  (greater-version-p version-id case-condition
					     :exclude exclude :strict T)))
		    (return-from SEARCH-CASES case)))
	       (symbol
		(return-from SEARCH-CASES case)))
	   finally
	     (return-from SEARCH-CASES nil))))


;;; ----------------------------------------------------------------------
;;; A small addition...
;;; ----------------------------------------------------------------------

(defmacro :VERSION-MESSAGE ((stream version-id &key (exclude nil)) &rest cases)
  `(format ,stream
	   (:version-case (,version-id :exclude ,exclude)
			  ,@cases)))


;;; ----------------------------------------------------------------------
;;; Also, some places where conditionalization occurs are not normally
;;; evaluated, which means that the versioning macro does not get a 
;;; chance to operate. This particularly happens in calls to Loom
;;; retrieval operations. The following macro allows direct control over
;;; whether parameters are evaluated or not, so we can force this if
;;; conditionalization is in fact required. All arguments are represented
;;; instead as two element lists, the first element of each parameter
;;; is either +, meaning evaluate, or -, meaning don't evaluate.
;;; ----------------------------------------------------------------------

(defmacro :WITH-CONDITIONALIZED-UNEVALUATED-ARGS
    (functor &rest args)
  `(,functor 
    ,@(mapcar #'(lambda (arg)
		  (case (first arg)
		    (+ (eval (second arg)))
		    (- (second arg)))) args)))

;;; ----------------------------------------------------------------------
;;; Make sure that unthought of exclusions are ignored whenever possible,
;;; e.g., when they do not introduce version numbers... Useful because
;;; some Lisp version might introduce these at random.
;;; ----------------------------------------------------------------------

(defun VERSION-NUMBERS-P (tentative-number-list)
  (loop for n 
      in (transform-versionstring tentative-number-list)
      always (numberp n)))

;;; ----------------------------------------------------------------------
;;; A utility that should be loaded early, so do it here...
;;; ----------------------------------------------------------------------

(defun CHECK-PACKAGE-PRESENT (package-name)
  (unless (find-package package-name)
    (format t "~2%WARNING: required package ~A is not in this Lisp image!!!" package-name)
    (format t "~%         compilation will fail with this configuration.")
    (format t "~%         Configuration is therefore breaking to allow loading of required optional packages (such as CLIM or IPC)")
    (break)))

;;; ----------------------------------------------------------------------
;;; Put Lispworks back into its default state if necessary...
;;; ----------------------------------------------------------------------

#+lispworks
(when *locked-keyword-package*
  (push "KEYWORD" CL-USER::*PACKAGES-FOR-WARN-ON-REDEFINITION*))

;;; ----------------------------------------------------------------------
;;; Seems like some (newer cheaper, i.e. free) Lisps do not have
;;; full complements of CL functions in some of the more arcane
;;; areas. Pick them off here so problems do not ensue.
;;; ----------------------------------------------------------------------

#-(or lispworks allegro)
(eval-when 
 (:execute :compile :load-toplevel :compile-toplevel)
 (unless (find-symbol "WITHOUT-REDEFINITION-WARNINGS")
   (defmacro WITHOUT-REDEFINITION-WARNINGS (&body body)
     `(let ((no-warnings)) ,@body))))



