(in-package "KPML")

;;; File: kpml-resource-management.lisp
;;; original version: KPML 0.8; John: IPSI: March 1995
;;;                             numerous updates at IPSI and Stirling...
;;;                             partial list below...
;;;
;;; KPML 4.0 beginning of XML versions for the input/output functions,
;;;          starting with the lexicon.
;;;
;;;      4.0 uses a separate directory interrogation function when we
;;;          know we are using for a set of matching files
;;;          (stable-directory-wild) because GNU CLISP (at least
;;;          under Linux) doesn't like handling these as other
;;;          Lisps do. See: x-platform
;;;
;;; This file replaces the previous collection of resource handling
;;; facilities that grew out of Penman's object-management. The
;;; functions are all multilingual compatible, and hence replace the
;;; Penman and KPML 0.7- files: object-management.lisp,
;;; resource-handling.lisp, and ml-resource-handling.lisp. The KPML
;;; 0.8 generic linguistic object display functions are used for
;;; simplifying the code considerably. In addition, full support of
;;; both multilingual operation modes (contrastive, multilingual,
;;; monolingual) and individual region operations on particular types
;;; of object is provided. There is also a patch facility where
;;; working changes to a set of resources can be placed prior to
;;; incorporation; this is respected by save-grammar (but not by
;;; individual grammar-internal save-functions).

;;; The loading and saving functions are by and large  mirror images of one 
;;; another  and have the following structure:
;;; 
;;;              FUNCTION                              PARAMETER
;;;     load-linguistic-resources                    language variety
;;;         load-grammar                           language variety
;;;             load-region                           lv  region
;;;                   load-systems                    lv  region
;;;                   load-choosers                   lv  region
;;;                   load-inquiries                  lv  region
;;;             load-default-orderings             language variety
;;;             load-punctuation                   language variety
;;;             load-language-patches              language variety
;;;         (load-inquiry-implementations)         language variety
;;;         (load-domains)                         language variety
;;;         load-lexicons                          language variety
;;;         load-examples                          language variety
;;;         (load-spl-defaults-and-macros)         language variety
;;;         (load-kpml-lg-specific-patches)        language variety
;;;         load-properties                        language variety
;;;
;;; Only the functions in brackets (since they deal with non-systemic
;;; information such as a KR system or Lisp) are not matched by corresponding
;;; save-functions.
;;; 
;;; Also: 0.8.15 introduces SAVE-UNCONDITIONALIZED-LINGUISTIC-RESOURCES.
;;;       0.9    adds the grammar patching facility.
;;;   1.0.3     : clearing flag sometimes ignored.
;;;   1.0.24    : string cleaning up options added to properties
;;;   1.0.30    : single language in contrastive mode OK
;;;   1.1 update: merging flag default corrected in many function calls.
;;;       PC:   : compatibility with Allegro CL 3.0.2 (mostly directory
;;;               accessing).
;;;   2.0       : previous explicit settings of *currently-used-file* are
;;;               now all removed since they are done properly by binding
;;;               in kpml-load. They were persisting and affecting objects
;;;               that they had no business affecting.
;;;   2.1       : function added for toggling versioning.
;;;   3.1       : possibility of explicit code page setting for Windows added
;;;   3.2       : parameterization of the name of the file for putting
;;;               code patches.
;;;   3.2.9     : (LWW)
;;;                allow us to put a code page declaration into the 
;;;                language-range file so that this can apply to all the
;;;                resources that are loaded afterwards. And Do another
;;;                PC code page switch after language range.
;;;   4.0       : load-semantics was confusing as it looks like all the
;;;               other load-X functions but took a directory instead.
;;;               Changed to be like the others (taking a language variety)
;;;               and a new function load-semantics-from-directory
;;;               added (which is just the old load-semantics of course).    
;;; ----------------------------------------------------------------------

;;; Loading/saving behavior is controlled by the following globals:
;;; the following defines the minimal profile that guarantees a
;;; full load of a set of linguistic resources...
;;; 1.2 :examples removed since it is now more likely that these be
;;;     added selectively as required.

(defvar *full-loading-saving-profile* 
  '(:systems :choosers :inquiries :default-orderings :punctuation 
    :lexemes :inquiry-implementations
    :domains 
    :inquiry-defaults
    :properties
    )
  )

;;; The full set of options available to the user is held in the
;;; following list...
(defvar *full-loading-saving-options*
    '(:systems :choosers :inquiries :default-orderings :punctuation
      :lexemes :examples :inquiry-implementations
      :domains :inquiry-defaults
      :properties :resource-patches :kpml-lg-specific-patches))

;;; There is also a further option, when :semantics is on the above
;;; list (which at present can only happen in the set up of the
;;; initial resources to be loaded when KPML is configured), then
;;; the KR and lisp contents of a further subdirectory Semantics
;;; is also loaded... This is not generally available since one
;;; does not want to reload an upper model very often.

(defvar *loading-saving-profile* *full-loading-saving-profile*)
;;; Linguistic objects of some type are only loaded if they are
;;; present on this list. Furthermore, the global:

(defvar *regions-in-focus* nil)
;;; contains a list of the regions that will be loaded (nil, perhaps
;;; somewhat counterintuitively, is the easiest representation for
;;; all regions). Similarly,

#+ignore (defvar *languages-in-focus* nil)

;;; contains a list of the languages that will be considered by
;;; default in multilingual and contrastive operations. This is
;;; only of relevance from the KPML window interface however,
;;; since that is where focusing on language sets is supported.

(defvar *code-patches-filename* "code-patches.lisp")
;;; allows parameterization of the file name used for code patches,
;;; or language specific method specializations. 

(defvar *resource-directory-versioning* T 
  "when set existing resource directories are not overwritten")

;;; Following returns a string that corresponds to a function
;;; being in a specified package, in order to create resource
;;; sets where the inquiry implementation functions can be
;;; placed freely in different packages. Such a package must
;;; be placed as value in the variable:
(defvar *package-for-inquiry-implementations* nil)
;;; Value should be either a single string or keyword denoting the package
;;; or an association list of languages (as specified in all_languages)
;;; and such strings. If the symbol is already from a package
;;; that is not the Penman package, then this information is
;;; preserved unless the flag:
(defvar *force-inquiry-implementation-package?* nil)
;;; is set true.

(defvar *clearing-flag* T)

;;; 1.1PC: there appears a bug in ACL3.0.2 that at some point a nasty
;;;  internal counter goes over 32768, at which point an etypecase
;;;  fails. Now, *if* this happens to occur in the middle of a file
;;;  operation that is writing files, we can *lose information*. This
;;;  is very ugly, therefore for PC, ACL3.0.2, the following flag is
;;;  set T by default. This then *always* makes a copy of a directory
;;;  before we do anything to it. The copy is placed in the working
;;;  tmp directory as used for hardcopies, etc.
(defvar *extra-cautious-mode* 
  #+(and acl3.0 aclpc) T 
  #-(and acl3.0 aclpc) nil)

;;; ----------------------------------------------------------------------
;;; Specials used...
(declaim (special all_languages
		  *clearing-flag*
		  *preselected-patch-collection*
		  *ordering-regions*
		  *merging-active*
		  curlan
		  common-lisp-user::*root-of-resources*
		  *patch-status*))

;;; ----------------------------------------------------------------------
;;; A language directory is defined as a non-empty directory
;;; corresponding to the given pathname. If it's empty, then
;;; it isn't considered since we have to create the internal
;;; directory structure. Have to make sure that we don't allow
;;; dot and double dot directories to fool us...
;;;
;;; KPML 4: the following definition did not seem to do much
;;;         concerned with its comment. It just returns
;;;         the argument given apparently.

(defun LG-DIRECTORY-P (pathname)
  #-acl3.0(stable-directory pathname)
  #+acl3.0(or
	   (stable-directory
	    (concatenate 'string
			 (namestring (coerce-directory pathname))
			 "*"))
	   (kpml-acl-directory
	    (concatenate 'string
			 (namestring (coerce-directory pathname))
			 "*"
			 (string *directory-delimiter*)
			 ))))


;;; ----------------------------------------------------------------------

(defun RESET-LOADING-SAVING-PROFILE ()
  (setf  *loading-saving-profile* *full-loading-saving-profile*))


;;; =======================================
;;;
;;;     LOADING LINGUISTIC RESOURCES
;;;
;;; =======================================

(defvar *ml-loading-mode* :monolingual)

;;; ----------------------------------------------------------------------
;;; First the functions the user is supposed to see...

;;; Following function loads everything it can find, but respecting
;;; the restrictions imposed by *loading-saving-profile*.
;;; Additionally the behavior is controlled by the values of the
;;; flags: *ml-loading-mode*
;;;        *regions-in-focus*      -- when NIL, all regions
;;;        *languages-in-focus*  -- when NIL, all languages
;;;
;;; Patch: 1.0.20
;;; Allows both multiple patches for a single version to be loaded
;;; one after the other and preselection of which patches are to
;;; be loaded without user intervention. This is particularly for
;;; the ease of setting up preloaded resource sets and combinations
;;; (e.g., as specified in site-specifics.lisp or user-specifics.lisp).

;;; An extra keyword parameter is added to load-linguistic-resources
;;; (:patches) which takes a list of *strings* (or lists of strings
;;; if multiple single version patches are to be loaded). The work
;;; is done by the following changes/additions to other functions
;;; in kpml-resource-maintenance.lisp

  ;; ----------------------------------------------------------------------
  ;; 3.2.33 loading contrastive leaves the loading mode in contrastive
  ;;        rather than as it was before contrastive loading. Changed.

(defun LOAD-LINGUISTIC-RESOURCES 
  (variety-designation &optional
		       &key
		       (root-directory common-lisp-user::*root-of-resources*)
		       (merge *merging-active*)   ;; 1.1
		       (clear *clearing-flag*)    ;; 1.0.3
		       (patches nil)              ;; 1.0.20
		       (objects nil))             ;; 1.1
  (let ((old-loading-saving-profile *loading-saving-profile*)
	(old-loading-mode *ml-loading-mode*))     ;; 3.2.33
    (when objects (setf *loading-saving-profile* objects))
    (when patches
      (setf *preselected-patch-collection* patches)               ;; 1.0.20
      (pushnew :resource-patches *loading-saving-profile*))
    (when (consp variety-designation)
	  (setf *ml-loading-mode* :contrastive))
    (catch 'loading-tag
      (case *ml-loading-mode*
	(:monolingual (load-single-resource-set
		       variety-designation root-directory merge clear))
	(:multilingual (load-single-resource-set
			variety-designation root-directory merge clear))
	(:contrastive 
	 (if (symbolp variety-designation) 
	     (setf variety-designation (list variety-designation))) ;1.0.30
	 (load-single-resource-set 
	  (first variety-designation) root-directory merge clear) ;1.0.30
	 (dolist (variety (cdr variety-designation))
	   (load-single-resource-set
	    variety root-directory T NIL)))))
    (setf *loading-saving-profile* old-loading-saving-profile)
    (setf  *ml-loading-mode* old-loading-mode)     ;; 3.2.33
    ;; 2.1 following should have coerce the result to boolean but didn't...
    (setf *patch-status* 
          (if (member :resource-patches *loading-saving-profile*) T nil))))


;;; Following function always loads full sets of grammar resources
;;; (but respecting region focusing). Patches are *not* loaded.
;;;
(defun LOAD-GRAMMAR (variety-designation &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (merge *merging-active*)
					 (clear *clearing-flag*))
  (let ((old-loading-saving-profile *loading-saving-profile*))
    (setf *loading-saving-profile* '(:systems :choosers :inquiries
					      :default-orderings
					      :punctuation
					      :inquiry-implementations))
    (load-linguistic-resources variety-designation
			     :root-directory root-directory
			     :merge merge
			     :clear clear)
    (setf *loading-saving-profile* old-loading-saving-profile)))


;;; Following function loads a single complete region (systems, choosers,
;;; and inquiries)...
(defun LOAD-REGION (variety-designation region &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (merge *merging-active*)
					 (clear *clearing-flag*))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:systems :choosers :inquiriers)
   :region-restriction (list region)))


;;; Following function loads only the systems of a region...
(defun LOAD-SYSTEMS (variety-designation region &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (merge *merging-active*)
					 (clear *clearing-flag*))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:systems)
   :region-restriction (list region)))

;;; Following function loads only the choosers of a region...
(defun LOAD-CHOOSERS (variety-designation region &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (merge *merging-active*)
					 (clear *clearing-flag*))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:choosers)
   :region-restriction (list region)))


;;; Following function loads only the inquiries of a region...
(defun LOAD-INQUIRIES (variety-designation region &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (merge *merging-active*)
					 (clear *clearing-flag*))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:inquiries)
   :region-restriction (list region)))


;;; Following function loads the default-orderings of a language
;;; variety (or varieties)...
(defun LOAD-DEFAULT-ORDERINGS (variety-designation &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (merge *merging-active*)
					 (clear *clearing-flag*))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:default-orderings)))



;;; Following function loads only the punctuation of a variety (or varieties).
(defun LOAD-PUNCTUATION (variety-designation &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (merge *merging-active*)
					 (clear *clearing-flag*))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:punctuation)))


;;; Following function loads only the properties for a variety (or varieties).
(defun LOAD-PROPERTIES (variety-designation &optional 
					    &key
					    (root-directory common-lisp-user::*root-of-resources*)
					    (merge *merging-active*)
					    (clear *clearing-flag*))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:properties)))


;;; Following function loads only the designated grammar patches
;;; for a language variety (or varieties)...
;;; 1.1 note here that the clearing flag is by default *always* off,
;;; since it does not make sense in theory to clear the resources that
;;; that the patches are patching!
;;; 
(defun LOAD-LANGUAGE-PATCHES (variety-designation 
			      &optional 
			      &key
			      (root-directory common-lisp-user::*root-of-resources*)
			      (merge *merging-active*)
			      (clear nil))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:resource-patches)))


;;; Following function loads only the inquiry-implementations of a 
;;; language variety (or varieties)...
(defun LOAD-INQUIRY-IMPLEMENTATIONS (variety-designation &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (merge *merging-active*)
					 (clear *clearing-flag*))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:inquiry-implementations))
  )


;;; Following added for speedy generation if really required... (1.1)
(defun LOAD-COMPILED-INQUIRY-IMPLEMENTATIONS 
    (variety-designation &optional 
     &key
     (root-directory common-lisp-user::*root-of-resources*))
  (unless (symbolp variety-designation)
    (warning "Attempt to operate on illegal language variety: "
	     variety-designation)
    (return-from LOAD-COMPILED-INQUIRY-IMPLEMENTATIONS nil))
  (let* ((lg-name (string variety-designation))
	 (lg-root-directory 
	  (pathname
	   (concatenate 'string (namestring root-directory) lg-name (string *directory-delimiter*)))))

    (cond ((lg-directory-p (pathname lg-root-directory))
	   (load-compiled-inquiry-implementations-from-directory
	    lg-root-directory))
	  (t
	   (format t "~% Language variety: ~A, is not currently available among
 the linguistic resources reachable from ~A~% " lg-name root-directory)))))
  
(defun LOAD-COMPILED-INQUIRY-IMPLEMENTATIONS-FROM-DIRECTORY 
    (lg-root-directory)	   
  (let* ((inq-implementations
	  (merge-pathnames (pathname lg-root-directory)  
			   "inquiry-implementations.lisp"))
	 (inq-implementations? (open inq-implementations :direction :probe))
	 (inquiry-implementations-increment
	  (merge-pathnames (pathname lg-root-directory) 
			   "inquiry-increment.lisp"))
	 (inquiry-implementations-increment?
	  (open inquiry-implementations-increment :direction :probe))
	 (compiled-implementations
	  (merge-pathnames (pathname lg-root-directory)  
			   "inquiry-implementations.fasl"))
	 (compiled-implementations? 
	  (open compiled-implementations :direction :probe))
	 (compiled-increment
	  (merge-pathnames (pathname lg-root-directory) 
			   "inquiry-increment.fasl"))
	 (compiled-increment?
	  (open compiled-increment :direction :probe))
	 (implementations-directory 
	  (merge-pathnames (pathname lg-root-directory) 
			   "Inquiry-implementations"))
	 (imps? (dir-exists-p implementations-directory)))

    (when (and inq-implementations? (not compiled-implementations?))
      (compile-file inq-implementations))

    (when (and inquiry-implementations-increment? (not compiled-increment?))
      (compile-file inquiry-implementations-increment))
    
    #+ignore(when imps?
	  (dolist (inquiry-implementation-file 
		   (stable-directory-wild
		    (merge-pathnames
		     (concatenate 'string (coerce-directory 
				     implementations-directory) "*.lisp")
		     "*.*.newest")))
	    (unless compiled version of file exists
		    (compile-file inquiry-implementation-file))
	    (load compiled-inquiry-implementation-file)))

    (when (and imps? (or inq-implementations? 
			 inquiry-implementations-increment?))
	  (warning "Inquiry implementations found both in main directory and in a subdirectory: compiled versions of those of the main directory are being loaded last."))
    
    (when inq-implementations?  (load compiled-implementations))
    (when inquiry-implementations-increment? (load compiled-increment))))


;;; Following function loads only the domain-files of a language variety
;;; (or varieties)...
(defun LOAD-DOMAINS (variety-designation 
			  &optional 
			  &key
			  (root-directory common-lisp-user::*root-of-resources*)
			  (merge *merging-active*)
			  (clear *clearing-flag*))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:domains)))


;;; Following function loads only the lexemes of a language variety...
(defun LOAD-LEXICONS (variety-designation 
			   &optional 
			   &key
			   (root-directory common-lisp-user::*root-of-resources*)
			   (merge *merging-active*)
			   (clear *clearing-flag*))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:lexemes)))


;;; Following function loads only the examples of a language variety
;;; (or varieties)...
(defun LOAD-EXAMPLES (variety-designation
			   &optional 
			   &key
			   (root-directory common-lisp-user::*root-of-resources*)
			   (merge *merging-active*)
			   (clear *clearing-flag*))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:examples)))


;;; 4.0
;;; Following new function loads only the semantics of a language variety
;;; (or varieties), which is the information in the Semantics directories.
;;; This should actually only be an upper model or some extension thereof.
;;;
(defun LOAD-SEMANTICS (variety-designation
		       &optional 
		       &key
		       (root-directory common-lisp-user::*root-of-resources*)
		       (merge *merging-active*)
		       (clear *clearing-flag*))
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge merge
   :clear clear
   :object-restriction '(:semantics)))

;;; Following function loads only the language variety specific
;;; patches to KPML code...
(defun LOAD-KPML-LG-SPECIFIC-PATCHES 
  (variety-designation &optional 
		       &key
		       (root-directory common-lisp-user::*root-of-resources*))

;;; Support for this may be removed, since the R3 release of the
;;; resources should not need any language specific patches, and
;;; their subsequent re-introduction for other languages should
;;;  not be encouraged.
  (parameterized-resource-handling
   variety-designation
   :root-directory root-directory
   :merge *merging-active*
   :clear *clearing-flag*
   :object-restriction '(:kpml-lg-specific-patches))

  )





;;; ----------------------------------------------------------------------
;;; Now the work...

;;; Get the loading of a single resource set started; gets the
;;; target directory, checks the variety designation, sets
;;; the global merging status control.
;;;
;;; 3.1 add a code page setter for Lispworks on PCs...
;;;
(defun LOAD-SINGLE-RESOURCE-SET
  (variety-designation root-directory merge clear)
  (unless (symbolp variety-designation)
	  (warning "Attempt to operate on illegal language variety: "
		   variety-designation)
	  (return-from LOAD-SINGLE-RESOURCE-SET nil))
  (let* ((lg-name (string variety-designation))
	 (lg-root-directory 
	  (pathname
	   (concatenate 'string (namestring root-directory) lg-name (string *directory-delimiter*))))
	 (old-merging-status *merging-active*)
	 (old-patch-status   *patch-status*))

    (cond ((lg-directory-p (pathname lg-root-directory))
	   (setf *merging-active* merge)
	   (setf *patch-status* nil)
           (with-code-page-settings 
            (variety-designation)
            (load-single-language-resources 
	     lg-name
	     lg-root-directory 
	     :clear clear))
	   (setf *merging-active* old-merging-status)
	   (setf *patch-status* old-patch-status)
	   )
	  (t
	   (format t "~% Language variety: ~A, is not currently available among 
 the linguistic resources reachable from ~A~% " lg-name root-directory)))))

;;; Get the actual business of loading done...
;;;
;;; In 1.0 can now have an additional file 
;;;    establishes the minimal language range of the resource.
;;;    This patch also establishes a standard way of specifying which
;;;    language varieties are to be expected for a resource set.
;;; 3.2.9 do a code-page switch on PCs after loading the 
;;;    language-range file.

(defun LOAD-SINGLE-LANGUAGE-RESOURCES 
  (lg-name lg-root-directory 
	   &optional &key 
	   (clear t))
  (let* ((lg-conditionalizer (intern (string-upcase lg-name) :keyword))
	 (patches 
	  (merge-pathnames (pathname lg-root-directory)  
			   *code-patches-filename*))
	 (code-patches? (open patches :direction :probe))
	 (lg-range                                          ;; 0.9.58
	  (merge-pathnames (pathname lg-root-directory) "language-range.lisp"))
	 (lg-range? (open lg-range :direction :probe))
	 (properties
	  (merge-pathnames (pathname lg-root-directory) "properties.lisp"))
	 (properties? (open properties :direction :probe))
	 )
    
    (cond ((lg-directory-p (pathname lg-root-directory))
           (when lg-range? (kpml-load lg-range))   ;; 0.9.58 (2.1 moved first)
	   ;; 3.2.9 do the code-page change if necessary...
	   (with-code-page-settings 
            (lg-conditionalizer)
	    (progn
	      (when (and (member :kpml-lg-specific-patches 
				 *loading-saving-profile*)
			 code-patches?) (load patches))
	      (unless *merging-active*		  
		(when clear 
		  (when (member :systems *loading-saving-profile*)
		    (erase-systems))
		  (when (member :choosers *loading-saving-profile*)
		    (erase-choosers))
		  (when (member :inquiries *loading-saving-profile*)
		    (erase-inquiries))
		  (when (member :default-orderings *loading-saving-profile*)
		    (erase-nonsystemic-orderings))
			 (when (member :lexemes *loading-saving-profile*)
			   (erase-lexicon))
			 (when (member :examples *loading-saving-profile*)
			       (erase-examples))
			 (when (member :inquiry-implementations
				       *loading-saving-profile*)
			   (warning 
			    "Old inquiry implementations being flushed.")
			   (flush-inquiry-implementation-functions))
			 ))
	      
	      (when (member :semantics *loading-saving-profile*)
		(load-semantics-from-directory lg-root-directory))

	      ;; Note: have to load inquiry implementations first 
	      ;;       since they may define new packages for the
	      ;;       inquiry implementation functions....
	      ;;
	      (when (member :inquiry-implementations *loading-saving-profile*)
		(load-inquiry-implementations-from-directory
		 lg-root-directory))

	      (load-grammar-from-directory lg-root-directory)
	      (when (member :domains *loading-saving-profile*)
		(load-domain-files-from-directory lg-root-directory))
	      (when (member :lexemes *loading-saving-profile*) 
		 (load-lexicon-files-from-directory lg-root-directory))
	      (when (member :examples *loading-saving-profile*)
		(load-example-files-from-directory lg-root-directory))

	      ;; The following *must* be loaded with the intended language as
	      ;; current language, otherwise the SPL parser (process-features)
	      ;; cannot recognize the answers to Q-inquiries reliably!
	      ;;
	      (when (member lg-conditionalizer all_languages)
		 (setf curlan lg-conditionalizer))
	      (when (member :inquiry-defaults *loading-saving-profile*)
		(load-inquiry-default-definitions-from-directory
		 lg-name lg-root-directory))
	      (when (and properties?
			 (member :properties *loading-saving-profile*))
		(kpml-load properties))
	      (when (member :resource-patches *loading-saving-profile*)
		(load-resource-patches lg-name lg-root-directory))
	      )))
	    (t
	     (format 
	      t "~% Language resource(s) root directory ~A not found.~% " 
	      lg-root-directory)))))


;;; Until KPML 0.7, loading was done via a defsys; but this doesn't allow
;;; us to further conditionalize the loading behavior, if, for example,
;;; we only want to focus on some specific regions, or some particular
;;; kinds of linguistic objects. So in KPML 0.8 a defsys is no longer
;;; generated and we work from the directory directly. (If this function
;;; does not find a Grammar directory, but it does find a defsys at
;;; root-directory, then it assumes that it has been applied on KPML 0.7
;;; compatible resources and loads as if, giving a warning that the
;;; directory structure be updated. Restriction to particular types
;;; of linguistic unit is not then enforced, the defsys is taken
;;; to define what must be loaded.)
;;;
;;; 4.0 extension for GNU CLISP under Unix/Linux.
;;;
(defun LOAD-GRAMMAR-FROM-DIRECTORY (root-directory)
  (let ((grammar-directory 
	 (coerce-directory
	  ;; 4.0 extension for CLISP
	  (merge-pathnames #-(or (and clisp unix) acl3.0) "Grammar/" 
	                   #+(or (and clisp unix) acl3.0) "Grammar" 
			   (pathname root-directory)))))
    (cond ((not (dir-exists-p grammar-directory))
	   (warning "Improper linguistic resource directory structure. Assuming Penman (or KPML 0.7) type resources -- these should be restructured!")
	   (kpml-0.7-load-grammar root-directory))
	  (t
	   (let* ((file-list 
;;; KPML 0.7-
;;; The following doesnt appear to work with merge-pathnames, so
;;; we use string version of the pathnames.... (I.e., we dont get
;;; a list of the required files back somehow...)
		   (append (if (member :systems *loading-saving-profile*)
			       (stable-directory-wild 
				(merge-pathnames
				 (concatenate 'string grammar-directory "*.systems")
				 "*.*.newest"))
			     nil)
			   (if (member :choosers *loading-saving-profile*)
			       (stable-directory-wild 
				(merge-pathnames
				 (concatenate 'string grammar-directory "*.choosers")
				 "*.*.newest"))
			     nil)
			   (if (member :inquiries *loading-saving-profile*)
			       (stable-directory-wild
				(merge-pathnames
				 (concatenate 'string  grammar-directory "*.inquiries")
				 "*.*.newest"))
			     nil)
			   (if (member :punctuation *loading-saving-profile*)
			       (let ((punctuation-file
				      (merge-pathnames
				       (concatenate 'string grammar-directory
						      "punctuation.gram"))))
				 (if (open punctuation-file :direction :probe)
				     (list punctuation-file)
				   nil)))
			   (if (member :default-orderings *loading-saving-profile*)
			       (let ((orderings-file
				      (merge-pathnames 
				       (concatenate 'string grammar-directory) 
				       "ordering-constraints.gram")))
				 (if (open orderings-file :direction :probe)
				     (list orderings-file)
				   nil))))))
	     (dolist (file (filter-files-against-regions file-list))
	       (kpml-load  file)
	       (clear-region-and-language-defaults))
	     )))))



;;; ----------------------------------------------------------------------
;;; Following function more or less repeats the loading procedure but
;;; for the subdirectory Patches. (Note that this can then recurse;
;;; well, why not?! :-) Although there is probably some better way
;;; of doing versioning!). If none of systems, choosers, or inquiries
;;; is on the loading profile, then we do a full load of any patches
;;; that are to be found.

(defun LOAD-RESOURCE-PATCHES (lg-name root-directory)
  (let* ((resource-patch-set 
	  #-acl3.0                                                            ;; 1.1
          (remove-if-not 
           #'(lambda (p) (lg-directory-p (coerce-directory p)))   ;; 2.1 fussy.
           (stable-directory-wild 
            (merge-pathnames "*Patches" (pathname root-directory))))
	  #+acl3.0
	  (let ((working 
		 (loop for d in (kpml-directory 
				  (coerce-directory 
				   (merge-pathnames 
				    "*" (pathname root-directory))))
		       collect (cons (acl-get-directory-name d) d))))
	    (loop for (name . dir) in working
		  when (and (>= (length name) 7)
			    (string= 
			     (subseq name (- (length name) 7)) "Patches"))
		  collect dir)))
	 (resource-patches (if (eq (length resource-patch-set) 1)  ;; 1.0.20
			     (list (first resource-patch-set))
			   (ascertain-required-patches 
			    lg-name resource-patch-set)))
	 (patches-directories
	  (mapcar #'coerce-directory 
		  (remove nil resource-patches)))                  ;; 1.0.20
	 (old-loading-saving-profile *loading-saving-profile*))
    (unless 
	(and resource-patch-set                                    ;; 0.9.23
	     patches-directories)
      (return-from LOAD-RESOURCE-PATCHES nil))
    (setf *patch-status* T)
    (unless (or (member :systems *loading-saving-profile*)
		(member :choosers *loading-saving-profile*)
		(member :inquiries *loading-saving-profile*))      ;; 0.9.23a
      (reset-loading-saving-profile))
    (loop for patches-directory in patches-directories             ;; 1.0.20
	do
	  (load-single-language-resources 
	   lg-name patches-directory :clear nil))
    (setf *loading-saving-profile* old-loading-saving-profile)
    ;; 2.1 following should have coerce the result to boolean but didn't...
    (setf *patch-status* 
          (if (member :resource-patches *loading-saving-profile*) T nil))))

;;; 1.0.20
;;; (allows several patch files at the same version level to be
;;; loaded at a time).
(defvar *preselected-patch-collection* nil)

(defun ASCERTAIN-REQUIRED-PATCHES (lg-name name-set)
  ;; 2.1
  ;;  one tiny little problem, since patches are directory names, if they
  ;;  are interrogated with pathname-name as was the case previously, then
  ;;  then return :unspecified or nil if they are treated as directories...
  ;;  so if they are coerced to directory form anywhere, this will mess
  ;;  up nicely here. What we should be doing nowadays is using the
  ;;  proper ANSI standard list representation of directory path names.
  ;;  For now, add in a cross-lisp compatibility function...
  (let ((options (mapcar #'(lambda (n) (cons (dirname-from-dir-pathname n) n)) name-set)))
    (mapcar #'(lambda (selection)
		(cdr (assoc selection options :test #'string=)))
	    (if *preselected-patch-collection*
		(required-patches-preselected options)
	      (required-patches-by-user lg-name options)))))

(defun REQUIRED-PATCHES-PRESELECTED (options)
  (let ((preselection (first *preselected-patch-collection*))
	(selections nil))
    (cond ((consp preselection)
	   (loop for s in preselection
	       when (assoc s options :test #'string=)
	       do (push s selections)))
	  ((stringp preselection)
	   (when (assoc preselection options :test #'string=)
	     (push preselection selections)))
	  (t
	   (warning "Ill-formed patch set selection: " preselection)))
    (when selections 
      (pop *preselected-patch-collection*))
    (reverse selections)))


;;;
;;; 4.1 Bremen, December 2007
;;;     added utility for regression testing...
;;;

(defun GET-PATCHES-TO-CHECK ()
  (let* ((lg-name (string curlan))
         (root-directory 
          (pathname
           (concatenate 'string (namestring
                                 common-lisp-user::*root-of-resources*) 
                        lg-name (string
                                 *directory-delimiter*))))
         ;;
         ;; first part based on LOAD-RESOURCE-PATCHES
         ;; but breaks off before actually loading anything...
         ;;
         (resource-patch-set 
          (remove-if-not 
           #'(lambda (p) (lg-directory-p (coerce-directory p)))     ;; 2.1 fussy.
           (stable-directory-wild 
            (merge-pathnames "*Patches" (pathname root-directory)))))
         (resource-patches (if (eq (length resource-patch-set) 1)  ;; 1.0.20
                               (list (first resource-patch-set))
                             (ascertain-required-patches 
                              lg-name resource-patch-set)))
         (patches-directories
          (mapcar #'coerce-directory 
                  (remove nil resource-patches)))                   ;; 1.0.20
         (old-loading-saving-profile *loading-saving-profile*))
    (if (and resource-patch-set                                    ;; 0.9.23
	     patches-directories)
        patches-directories
      nil)))

;;; 2.0 following was nicely wreaking havoc in its options parameter
;;;     by carrying out destructive deletions...
;;; 2.1 message made more informative as the behaviour here is not
;;;     particulary self-explanatory.
;;;     ...also added a catch for dropping out of the menu choice...
;;; 4.0 obviously was not used very much. Needed to add in a further
;;;     way out when *all* patches are selected for loading, previously
;;;     this just bottomed out in a NIL. Also one of the branches was
;;;     still returning the patches to load backwards.
;;;
(defun REQUIRED-PATCHES-BY-USER (lg-name options)
  (let* ((selections nil)
         (response
          (catch 'kpml-say-error
            (loop while options
	          do 
	          (let* ((message-format 
                          (concatenate
                           'string
                           "Patching: ~A;  Select a "
                           (if selections "(further) " "")
                           "patch directory: ~2% You will be prompted for further patches ~% either until you select 'no more' or ~% there are no further options. "
                           "~%The patches will be loaded in the order selected and shown. "
                           (if selections "~%  Patches selected so far:  ~{~%      ~S~}." "~A")))
                         (message (format nil message-format lg-name (if selections selections "")))
                         (selection 
		          (askwindow :choice message
                                     (append (mapcar #'car options) (list '|no more|)))))
	            (when (eq selection '|no more|)
	              (return-from REQUIRED-PATCHES-BY-USER selections)) ;; 4.0 was backwards...
	            (when selection
	              (setf selections (append selections (cons selection nil)))
	              (setf options 
		            (loop for x in options
		                  unless (eq selection (car x))
		                  collect x))))
		  finally                                                ;; 4.0 new branch
		  (when selections
		    (return-from REQUIRED-PATCHES-BY-USER selections))
		  ))))
    (if (consp response)
        selections
      nil)))


;;; End of 1.0.20
;;; ----------------------------------------------------------------------


(defun FILTER-FILES-AGAINST-REGIONS (file-list)
;;; Need to filter the files to be loaded against the focused regions;
;;; this is possibly best done with one of the Lisp functions for taking
;;; apart pathnames... Note, when *regions-in-focus* is NIL, then all
;;; files are loaded.
  (if *regions-in-focus*
      (loop for file in file-list
	    when (member (intern (pathname-name file)
				 "KPML")
			 *regions-in-focus*)
	    collect file)
    file-list))





;;; Straight loading of everything grammatical from a single
;;; directory specified as parameter, with no conditionalizations...

(defun FORCED-GRAMMAR-LOAD (root-directory)
  (let ((file-list 
	  (append (stable-directory-wild 
		    (merge-pathnames 
		      (concatenate 'string (namestring root-directory) "*.systems")
		      "*.*.newest"))
		  (stable-directory-wild
		    (merge-pathnames 
		      (concatenate 'string (namestring root-directory) "*.choosers")
		      "*.*.newest"))
		  (stable-directory-wild
		    (merge-pathnames 
		      (concatenate 'string (namestring root-directory) "*.inquiries")
		      "*.*.newest"))
		  (stable-directory-wild
		    (merge-pathnames  
		      (concatenate 'string (namestring root-directory) "*.gram")
		      "*.*.newest")))))
    (dolist (file file-list)
      (kpml-load  file)
      (clear-region-and-language-defaults))))




;;;----------------------------------------------------------------------
;;; Lexicons, examples, etc. loading... uses old functions from
;;; KPML 0.7, renamed to show that they expect their directory
;;; to be already known.
;;;
;;; KPML 4.0 - xml mode added.
;;;            XML lexicons are expected in the resource directory 
;;;            XML-Lexicons and have the extension .xlx
;;;
(defvar *lexicon-files* nil "list of lexicon files used")

(defun LOAD-LEXICON-FILES-FROM-DIRECTORY (lg-root-directory)	   
;;; 0.7.24
;;; Now resets the language defaults to nil before each file
;;; loaded, so that if a file does not contain an explicit
;;; in-language declaration, the normal expectation that it
;;; holds for all languages is enforced...
  (let* ((lexicons-directory 
	  (merge-pathnames (pathname lg-root-directory) 
			   (if (xml-mode :lexicon)
			       "XML-lexicons" "Lexicons")))
	 (lexicons? (dir-exists-p lexicons-directory)))
    (when lexicons?
	  (dolist (lexicon-file 
		   (stable-directory-wild 
		    (merge-pathnames
		     (concatenate 'string (coerce-directory lexicons-directory) "*.lexicon")
		     "*.*.newest")))
	    (setf *current-default-languages* nil)
	    (pushnew lexicon-file *lexicon-files*)
	    (kpml-load lexicon-file)
	    (clear-region-and-language-defaults)))
    (dolist (support-file 
	     (stable-directory-wild 
	      (merge-pathnames
	       (concatenate 'string (namestring lg-root-directory) 
			    (if (xml-mode :lexicon) "*.xlx" "*.lexicon"))
	       "*.*.newest")))
      (setf *current-default-languages* nil)
      (if (xml-mode :lexicon)
	  (kpml-xml-lexicon-load (merge-pathnames support-file))
	(kpml-load (merge-pathnames support-file)))
      (clear-region-and-language-defaults))))

(defun LOAD-DOMAIN-FILES-FROM-DIRECTORY (lg-root-directory)
  (let* ((domains-directory 
	  (merge-pathnames (pathname lg-root-directory) "Domains"))
	 (domains? (dir-exists-p domains-directory)))
    (when domains?
	  (dolist (domain-file 
		   (stable-directory-wild
		    (merge-pathnames
		     (concatenate 
			 'string 
		       (coerce-directory domains-directory) "*."
		       *kr-file-extension*)
		     "*.*.newest")))
		  (load domain-file)))
    
    (dolist (support-file 
	     (stable-directory-wild 
	      (merge-pathnames
	       (concatenate 'string (namestring lg-root-directory) "*."
			    *kr-file-extension*)
	       "*.*.newest")))
	    (load (merge-pathnames support-file)))))

(defun LOAD-EXAMPLE-FILES-FROM-DIRECTORY (lg-root-directory)
  (let* ((examples-directory 
	  (merge-pathnames (pathname lg-root-directory) "Examples"))
	 (examples? (dir-exists-p examples-directory)))
    (when examples?
	  (dolist (example-file 
		   (append
		    (stable-directory-wild
		     (merge-pathnames
		      (concatenate 'string (coerce-directory examples-directory) "*.ex")
		      "*.*.newest"))
		    (stable-directory-wild
		     (merge-pathnames
		      (concatenate 'string (coerce-directory examples-directory) "*.spl")
		      "*.*.newest"))))
	    (kpml-load example-file)
	    (clear-region-and-language-defaults)))
    (dolist (support-file 
	     (stable-directory-wild 
	      (merge-pathnames
	       (concatenate 'string (namestring lg-root-directory) "*.spl")
	       "*.*.newest")))
      (kpml-load (merge-pathnames support-file))
      (clear-region-and-language-defaults))
    ))


;;; New: KPML 0.8 resource organization.

(defun LOAD-INQUIRY-IMPLEMENTATIONS-FROM-DIRECTORY (lg-root-directory)	   
  (let* ((inq-implementations
	  (merge-pathnames (pathname lg-root-directory)  "inquiry-implementations.lisp"))
	 (inq-implementations? (open inq-implementations :direction :probe))
	 (inquiry-implementations-increment
	  (merge-pathnames (pathname lg-root-directory) "inquiry-increment.lisp"))
	 (inquiry-implementations-increment?
	  (open inquiry-implementations-increment :direction :probe))
	 (implementations-directory 
	  (merge-pathnames (pathname lg-root-directory) 
			   "Inquiry-implementations"))
	 (imps? (dir-exists-p implementations-directory)))
    (when imps?
	  (dolist (inquiry-implementation-file 
		   (stable-directory-wild 
		    (merge-pathnames
		     (concatenate 'string (coerce-directory 
				     implementations-directory) "*.lisp")
		     "*.*.newest")))
		    (load-no-warnings inquiry-implementation-file)))
    (when (and imps? (or inq-implementations? 
			 inquiry-implementations-increment?))
	  (warning "Inquiry implementations found both in main directory and in a subdirectory: those of the main directory are being loaded last."))
    
    (when inq-implementations?  (load-no-warnings inq-implementations))
    (when inquiry-implementations-increment?
	  (load inquiry-implementations-increment))))


(defun LOAD-SEMANTICS-FROM-DIRECTORY (lg-root-directory)	   
  (let* ((semantics-directory 
	 (merge-pathnames (pathname lg-root-directory) 
			  "Semantics"))
	 (imps? (dir-exists-p semantics-directory)))
    (when imps?
      (dolist 
	  (semantics-file 
	      (remove-duplicates
	       (append 
		(stable-directory-wild 
		 (merge-pathnames
		  (concatenate 'string (coerce-directory 
					semantics-directory) "*.lisp")
		  "*.*.newest"))
		(stable-directory-wild 
		 (merge-pathnames
		  (concatenate 'string (coerce-directory 
					semantics-directory) "*."
					*kr-file-extension*)
		  "*.*.newest")))
	       :test #'string=))
	(load semantics-file)))))


;;; ----------------------------------------------------------------------
;;; Little function for arbitrarily restricting the general resource
;;; load in order to generate the more specific loading functions
;;; that are made available.

(defun PARAMETERIZED-RESOURCE-HANDLING (variety-designation &optional 
					 &key
					 (direction :input)
					 (root-directory common-lisp-user::*root-of-resources*)
					 (merge *merging-active*)
					 (clear *clearing-flag*)
					 (inheriting-from nil)
					 (inquiry-package nil)
					 (region-restriction nil)
					 (object-restriction nil))
  (let ((old-loading-saving-profile *loading-saving-profile*)
	(old-regions-in-focus *regions-in-focus*))
    (setf *loading-saving-profile* object-restriction)
    (setf *regions-in-focus* region-restriction)
    (unwind-protect
	(block nil
	       (cond ((eq direction :input)
		      (load-linguistic-resources 
		       variety-designation
		       :root-directory root-directory
		       :merge merge
		       :clear clear))
		     (t
		      (save-linguistic-resources 
		       variety-designation
		       :root-directory root-directory
		       :inheriting-from inheriting-from
		       :inquiry-package inquiry-package)))))
    (setf *loading-saving-profile* old-loading-saving-profile)
    (setf *regions-in-focus* old-regions-in-focus)
    (values)))

;;; ----------------------------------------------------------------------




;;; =======================================
;;;
;;;     SAVING LINGUISTIC RESOURCES
;;;
;;; =======================================


(defvar *ml-saving-mode* :monolingual)
(defvar *file-writing* nil)
(defvar *saving-patches-mode* nil)

;;; ----------------------------------------------------------------------
;;; First the functions the user is supposed to see...

;;;              FUNCTION                              PARAMETER
;;;     save-linguistic-resources                    language variety
;;;         save-grammar                           language variety
;;;             save-region                           lv  region
;;;                   save-systems                    lv  region
;;;                   save-choosers                   lv  region
;;;                   save-inquiries                  lv  region
;;;             save-default-orderings             language variety
;;;             save-punctuation                   language variety
;;;             save-language-patches              language variety
;;;         save-lexicons                          language variety
;;;         save-examples                          language variety
;;;         save-properties                        language variety
;;;
;;; ----------------------------------------------------------------------
;;; Following function saves everything it can find, but respecting
;;; the restrictions imposed by *loading-saving-profile*.
;;; It also requires for the multilingual option that the variable
;;; *languages-in-focus* is properly set up, since it is this
;;; that determines which languages appear in the final multilingual
;;; specification. If this is not set, then the default assumption
;;; is that all languages are to appear. Thus, in the multilingual
;;; case, the variety designation is simply a label for the resource set:
;;; one cannot deduce the languages it covers from this label.
;;; Finally, there is the extra possibility of creating a new set
;;; of resources by means of inheritance. Here the only 
;;; *loading-saving-profile* that makes sense is :monolingual and
;;; one requires the additional information of which language is
;;; going to be taken as source. This is triggered by using a further
;;; optional keyword parameter 
;;; :inheriting-from, which contains a single variety designation.
;;; The KPML interface, as usual, attempts to make all these parameters
;;; as transparent as possible.

(defun SAVE-LINGUISTIC-RESOURCES 
  (variety-designation &optional
		       &key
		       (root-directory common-lisp-user::*root-of-resources*)
		       (inheriting-from nil)
		       (inquiry-package nil))
  (let ((old-inquiry-package *package-for-inquiry-implementations*)
	(old-loading-saving-profile *loading-saving-profile*))
    (setf *file-writing* T)
    (when inquiry-package
	  (setf *package-for-inquiry-implementations* inquiry-package))
    (cond (inheriting-from 
	   (setf *loading-saving-profile*
	     (remove :resource-patches *loading-saving-profile*))
	   (save-single-resource-set
	    variety-designation root-directory NIL inheriting-from)
	   (pushnew variety-designation all_languages))
	  (t
	   (case *ml-saving-mode*
		 (:monolingual (save-single-resource-set
				variety-designation root-directory NIL NIL))
		 (:multilingual (save-single-resource-set
				 variety-designation root-directory T NIL))
		 (:contrastive 
		  (dolist (variety variety-designation)
			  (save-single-resource-set
			   variety root-directory NIL NIL))))))
    (setf *package-for-inquiry-implementations* old-inquiry-package)
    (setf *loading-saving-profile* old-loading-saving-profile)
    (setf *file-writing* nil)))

;;; ----------------------------------------------------------------------
;;; The following particular saving functions simply use the above
;;; but setting the object- and region-restrictors appropriately to
;;; get their respective behaviors.... They are identical to the
;;; corresponding load-functions, simply using the change in :direction
;;; parameter.... The save-grammar function does *not* save patches.

(defun SAVE-GRAMMAR (variety-designation 
		     &optional
		     &key
		     (root-directory common-lisp-user::*root-of-resources*)
		     (inheriting-from nil)
		     (inquiry-package nil))
  (setf *inquiry-definitions-given* nil)
  (parameterized-resource-handling
   variety-designation
   :direction :output
   :root-directory root-directory
   :inheriting-from inheriting-from
   :inquiry-package inquiry-package
   :object-restriction '(:systems :choosers :inquiries
				  :default-orderings
				  :punctuation
				  :inquiry-implementations)))
   

(defun SAVE-REGION (variety-designation region &optional
				     &key
				     (root-directory common-lisp-user::*root-of-resources*)
				     (inheriting-from nil)
				     (inquiry-package nil))
  (parameterized-resource-handling
   variety-designation
   :direction :output
   :root-directory root-directory
   :inheriting-from inheriting-from
   :inquiry-package inquiry-package
   :object-restriction '(:systems :choosers :inquiriers)
   :region-restriction (list region)))



(defun SAVE-SYSTEMS (variety-designation region &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (inheriting-from nil))
  (parameterized-resource-handling
   variety-designation
   :direction :output
   :root-directory root-directory
   :inheriting-from inheriting-from
   :object-restriction '(:systems)
   :region-restriction (list region)))


(defun SAVE-CHOOSERS (variety-designation region &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (inheriting-from nil))
  (parameterized-resource-handling
   variety-designation
   :direction :output
   :root-directory root-directory
   :inheriting-from inheriting-from
   :object-restriction '(:choosers)
   :region-restriction (list region)))



(defun SAVE-INQUIRIES (variety-designation region &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (inheriting-from nil)
					 (inquiry-package nil))
  (parameterized-resource-handling
   variety-designation
   :direction :output
   :root-directory root-directory
   :inheriting-from inheriting-from
   :inquiry-package inquiry-package
   :object-restriction '(:inquiries)
   :region-restriction (list region)))



(defun SAVE-DEFAULT-ORDERINGS (variety-designation &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (inheriting-from nil))
  (parameterized-resource-handling
   variety-designation
   :direction :output
   :inheriting-from inheriting-from
   :root-directory root-directory
   :object-restriction '(:default-orderings)))


(defun SAVE-PUNCTUATION (variety-designation &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (inheriting-from nil))
  (parameterized-resource-handling
   variety-designation
   :direction :output
   :root-directory root-directory
   :inheriting-from inheriting-from
   :object-restriction '(:punctuation)))


(defun SAVE-PROPERTIES (variety-designation &optional 
					 &key
					 (root-directory common-lisp-user::*root-of-resources*)
					 (inheriting-from nil))
  (parameterized-resource-handling
   variety-designation
   :direction :output
   :root-directory root-directory
   :inheriting-from inheriting-from
   :object-restriction '(:properties)))

(defun SAVE-LANGUAGE-PATCHES (variety-designation 
			      &optional 
			      &key
			      (root-directory common-lisp-user::*root-of-resources*)
			      (inheriting-from nil))
  (parameterized-resource-handling
   variety-designation
   :direction :output
   :inheriting-from inheriting-from
   :root-directory root-directory
   :object-restriction '(:resource-patches)))


;;; There is no automatic saving of KR files...
;;;         save-domain-files                      language variety
;;; although we could save the annotations with write-annotations
;;; if anyone wanted...

;;; Following function only saves the lexemes of a language variety...
(defun SAVE-LEXICONS (variety-designation 
		      &optional 
		      &key
		      (root-directory common-lisp-user::*root-of-resources*)
		      (inheriting-from nil))
  (parameterized-resource-handling
   variety-designation
   :direction :output
   :inheriting-from inheriting-from
   :root-directory root-directory
   :object-restriction '(:lexemes)))



;;; Following function only saves the examples of a language variety
;;; (or varieties)...
(defun SAVE-EXAMPLES (variety-designation
		      &optional 
		      &key
		      (root-directory common-lisp-user::*root-of-resources*)
		      (inheriting-from nil))
  (parameterized-resource-handling
   variety-designation
   :direction :output
   :root-directory root-directory
   :inheriting-from inheriting-from
   :object-restriction '(:examples)))


;;; ----------------------------------------------------------------------
;;; Then the work...

(defun SAVE-SINGLE-RESOURCE-SET 
  (variety root-directory multilingual inheriting-from)
  (unless (symbolp variety)
	  (warning "Attempt to operate on illegal language variety: "
		   variety)
	  (return-from SAVE-SINGLE-RESOURCE-SET nil))
  (let* ((lg-name (string variety))
	 (old-curlan curlan)
	 (lg-root-directory 
	  (pathname
	   (concatenate 'string (namestring root-directory) lg-name (string *directory-delimiter*)))))
    
    (check-resource-directory-existence 
     lg-name root-directory lg-root-directory)
    (unless *regions-in-focus* (setf  *inquiry-definitions-given* nil))
    (if inheriting-from
	(setf curlan inheriting-from)
      (setf curlan variety))
    (save-single-language-resources 
     lg-root-directory 
     :ml multilingual
     :inheriting-from inheriting-from
     :inheriting-to variety)
    (setf curlan old-curlan)))


;;; ----------------------------------------------------------------------
;;; 0.8.26; Allegro added for automatic directory creation...
;;; 1.0:    added non-overwrite option for existing resource directories

;;; Following function checks that a directory corresponding to the
;;; language variety to be saved actually exists. If one does not 
;;; exist, it makes one. If it does exist and the non-overwrite option
;;; is activated (the default), then the existing is copied to a
;;; new name and saving proceeds to a new version with the same 
;;; name.

(defun CHECK-RESOURCE-DIRECTORY-EXISTENCE 
    (lg-name root-directory lg-root-directory)
  (cond ((not (lg-directory-p (pathname lg-root-directory)))
	 (message 
	  "Language variety: " lg-name 
	  ", is not currently available among the linguistic resources reachable from " 
          root-directory ": creating.")
	 (create-new-resource-directory lg-root-directory))
	(*resource-directory-versioning*
	 (when *extra-cautious-mode*
	       (back-up-resource
		lg-name *example-runner-results* lg-root-directory
		:nondestructive))
	 (message
	  "Existing resource directory for language variety "
	  lg-name " is being backed up and replaced...")
	 (back-up-resource lg-name root-directory lg-root-directory)
	 (create-new-resource-directory lg-root-directory))
	(t
	 (message 
	  "Existing resource definition directory being used for save."))))

(defun MAKE-BACKED-UP-RESOURCE-DIRECTORY-NAME (name)
  (multiple-value-bind 
   (second minute hour date month year) 
   (get-decoded-time)
   (format nil "~a-~a~2,'0D~2,'0D-~2,'0D~2,'0D~2,'0D" 
	   name year month date hour minute second)))

;;; ----------------------------------------------------------------------
;;; 4.0
;;; All the very platform dependent backup and directory copying 
;;; functions from 3.2 and before moved to platform independence
;;; module.
;;; ----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; Get the actual business of saving done...
;;;

(defun SAVE-SINGLE-LANGUAGE-RESOURCES 
  (lg-root-directory &optional 
		     &key 
		     (ml nil)
		     (inheriting-from nil)
		     (inheriting-to nil))
  (cond ((lg-directory-p (pathname lg-root-directory))
	 (cond ((member :resource-patches *loading-saving-profile*)
		(save-resource-patches-to-directory 
		 lg-root-directory ml inheriting-to))
	       (t
		(save-language-range-to-directory        ;; 0.9.58
		 lg-root-directory ml inheriting-to)
		(save-grammar-to-directory 
		 lg-root-directory ml inheriting-from inheriting-to)
		(when (member :lexemes *loading-saving-profile*) 
		  (save-lexicon-files-to-directory 
		   lg-root-directory ml inheriting-from inheriting-to))
		(when (member :examples *loading-saving-profile*)
		  (save-example-files-to-directory 
		   lg-root-directory ml inheriting-from inheriting-to))
		(when (member :properties *loading-saving-profile*)
		  (save-language-properties-to-directory
		   lg-root-directory ml
		   inheriting-from inheriting-to))))
	       )
	 (t
	  (format t "~% Language root directory ~A not found.~% " 
		  lg-root-directory))))


(defun SAVE-GRAMMAR-TO-DIRECTORY 
  (root-directory &optional (ml nil)(inheriting-from nil)(inheriting-to nil))
  (let ((grammar-directory 
	 (merge-pathnames 
	  (concatenate 'string "Grammar" (string *directory-delimiter*))
	  (pathname root-directory))))
    ;; 4.0 this was forgotten I think...
    ;;     needs to be reset so that inquiries are actually saved.
    (setf *inquiry-definitions-given* nil)
    (save-regions-to-directory 
     grammar-directory ml inheriting-from inheriting-to)
    (when (member :punctuation *loading-saving-profile*)
	  (write-punctuation 
	   grammar-directory :ml ml :inheriting-from inheriting-from
	   :inheriting-to inheriting-to 
	   :concerned-languages *languages-in-focus*))
    (when (member :default-orderings *loading-saving-profile*)
	  (write-ordering-constraints 
	   grammar-directory :ml ml
	   :inheriting-from inheriting-from
	   :inheriting-to inheriting-to
	   :concerned-languages *languages-in-focus*))))
;;;

(defun SAVE-REGIONS-TO-DIRECTORY (directory ml inheriting-from inheriting-to)
  (let ((old-regions-in-focus *regions-in-focus*))
    (unless *regions-in-focus* (setf *regions-in-focus* 
				     (get-regions-to-save)))
    (dolist (region *regions-in-focus*)
	    (write-region region directory ml inheriting-from inheriting-to))
    (when (member 'nil *regions-in-focus*)
	  (warning "During saving, there were systems without region 
assignments which have been
 written to the pseudo-region \"NIL\"."))
    (setf *regions-in-focus* old-regions-in-focus)))

;;; 
;;; Note, the get-regions-to-save (and probably several other functions)
;;; have to be sensitive to the *ml-saving-mode* so that when
;;; multilingual it is the union of the regions for the 
;;; languages covered.
(defun GET-REGIONS-TO-SAVE ()
  (let ((regions-to-save nil)
	(old-curlan curlan))
    (case *ml-saving-mode*
	  ((:monolingual :contrastive)
	   (get-regions))
	  (:multilingual
	   (loop for lg in (if *languages-in-focus* *languages-in-focus*
			     all_languages)
		 do
		 (setf curlan lg)
		 (loop for r in (get-regions)
		       do (pushnew r regions-to-save)))
	   (setf curlan old-curlan)
	   (reverse regions-to-save)))))


;;; ----------------------------------------------------------------------
(defun SAVE-RESOURCE-PATCHES-TO-DIRECTORY (lg-root-directory ml lg)
  (let ((patch-directory 
	 (merge-pathnames (make-patch-file-name) (pathname lg-root-directory)))
	(old-loading-saving-profile *loading-saving-profile*))
    (create-new-resource-directory patch-directory)
    (if (or (member :systems *loading-saving-profile*)
	    (member :choosers *loading-saving-profile*)
	    (member :inquiries *loading-saving-profile*))
	(setf *loading-saving-profile*
	  (remove :resource-patches *loading-saving-profile*))
      (setf *loading-saving-profile*
	'(:systems :choosers :inquiries :default-orderings :punctuation)))
    (format *trace-output* 
	    "~%;;; Searching resource definitions for patches...")
    (setf *saving-patches-mode* T)
    (save-grammar-to-directory patch-directory ml nil lg)
    (format *trace-output* "~%;;; Any patches found have now been saved.")
    (setf *saving-patches-mode* nil)
    (setf *loading-saving-profile* old-loading-saving-profile)
    ))


(defun MAKE-PATCH-FILE-NAME ()
  (multiple-value-bind 
   (second minute hour date month year) 
   (get-decoded-time)
   (concatenate 'string
		(format nil "~a~2,'0D~2,'0D-~2,'0D~2,'0D~2,'0D-Patches" 
			year month date hour minute second)
		(string *directory-delimiter*))))


;;; ----------------------------------------------------------------------
;;; Slightly modified KPML 0.7- code...
;;; 0.8.28 CLtL2 pathname merging for extensions added.

  ;; 4.0 XML conditionalization added.
  ;;         experimental. May need to refine the treatment for
  ;;         the multilingual options. Also quite redundent at
  ;;         present. Should take out the repetition when this
  ;;         lot stabilises.
  ;;
(defun WRITE-REGION (region root-directory ml inheriting-from inheriting-to)
  (when (member :systems *loading-saving-profile*)
    (let ((region-file-set 
	   (merge-pathnames 
	    root-directory 
	    (ecase *object-output-mode*
	      (:xml   (string-append (string region) "-SYSTEMS"))
	      (:ascii (string region))))))
      (create-systems-of-region-file 
       region 
       (add-pathname-extension region-file-set (ecase *object-output-mode*
						      (:xml   "xml")
						      (:ascii "systems")))
       :ml ml
       :concerned-languages *languages-in-focus*
       :inheriting-from inheriting-from
       :inheriting-to inheriting-to)))
  (when (member :choosers *loading-saving-profile*)
    (let ((region-file-set 
	   (merge-pathnames 
	    root-directory 
	    (ecase *object-output-mode*
	      (:xml   (string-append (string region) "-CHOOSERS"))
	      (:ascii (string region))))))
      (create-choosers-of-region-file
	   region
	   (add-pathname-extension  
	    region-file-set  (ecase *object-output-mode*
			       (:xml   "xml")
			       (:ascii "choosers")))
	   :ml ml
	   :concerned-languages *languages-in-focus*
	   :inheriting-from inheriting-from
	   :inheriting-to inheriting-to)))
  (when (member :inquiries *loading-saving-profile*)
    (let ((region-file-set 
	   (merge-pathnames 
	    root-directory 
	    (ecase *object-output-mode*
	      (:xml   (string-append (string region) "-INQUIRIES"))
	      (:ascii (string region))))))

      (create-inquiries-of-region-file
       region
       (add-pathname-extension  region-file-set  (ecase *object-output-mode*
							(:xml   "xml")
							(:ascii "inquiries")))
       :ml ml
       :concerned-languages *languages-in-focus*
       :inheriting-from inheriting-from
       :inheriting-to inheriting-to))))

(defun ADD-PATHNAME-EXTENSION (file extension)
  #+CLTL1 (merge-pathnames file extension)
  #+(or CLTL2 aclpc)
  (merge-pathnames
   file
   (make-pathname :type extension)))
	


;-------------------------------------------------------------------------
; Support functions: Systems and gates...

(defun CREATE-SYSTEMS-OF-REGION-FILE (region file-pathname 
					     &key 
					     (ml nil)
					     (inheriting-from curlan)
					     (inheriting-to curlan)
					     (concerned-languages nil))
  (let ((system-list nil)
	(old-curlan curlan))
    (when inheriting-from (setf curlan inheriting-from))
    (unless concerned-languages (setf concerned-languages all_languages))
	    
    (setf system-list 
	  (if ml 
	      (systems-of-region-of-languages region concerned-languages)
	    (systems-of-region region)))
    (when *saving-patches-mode*
      (setf system-list (select-patched-systems 
			 system-list concerned-languages)))
    (when system-list
      (write-systems file-pathname system-list 
		     :ml ml
		     :region-specified region
		     :lg-specified inheriting-to)
      (if *saving-patches-mode*
	  (format *trace-output* 
		  (concatenate
		   'string 
		   "~%Created evaluable patch file of some systems of region ~30<~A~>. " #-acl3.0 "~
"
		   "~20<(~a systems)~>")
		  region (length system-list))
	(format *trace-output* 
		(concatenate
		 'string
		 "~%Created evaluable file for systems of region        ~30<~A~>. " #-acl3.0 "~
"
		 "~20<(~a systems)~>")
		region (length system-list))))
    (setf curlan old-curlan)))
  

; ----------------------------------------------------------------------
;; Patch selection filters...

(defun SELECT-PATCHED-SYSTEMS (system-list lgs)
  (loop for s in system-list
      when 
	(loop for l in lgs thereis (fetch-system-patch-status s l))
      collect s))

(defun SELECT-PATCHED-CHOOSERS (chooser-list lgs)
  (loop for c in chooser-list
      when 
	(loop for l in lgs thereis (fetch-chooser-info c 'patch-status l))
      collect c))

(defun SELECT-PATCHED-INQUIRIES (inquiry-list lgs)
  (loop for i in inquiry-list
      when 
	(loop for l in lgs thereis (fetch-inquiry-info i 'patch-status l))
      collect i))


;-------------------------------------------------------------------------
; Support functions: Choosers...

(defun CREATE-CHOOSERS-OF-REGION-FILE (region file-pathname 
					      &key 
					      (ml nil)
					      (inheriting-from curlan)
					      (inheriting-to curlan)
					      (concerned-languages nil))
  (let ((chooser-list nil)
	(old-curlan curlan))
    (when inheriting-from (setf curlan inheriting-from))
    (unless concerned-languages (setf concerned-languages all_languages))

    (setf chooser-list 
	  (if ml 
	      (choosers-of-region-of-languages region concerned-languages)
	    (choosers-of-region region)))
    (when *saving-patches-mode*
      (setf chooser-list 
	(select-patched-choosers chooser-list concerned-languages)))
    (cond (chooser-list
	   (write-choosers file-pathname chooser-list
			   :ml ml
			   :region-specified region
			   :lg-specified inheriting-to)
	   (setf curlan old-curlan)
	   (if *saving-patches-mode*
	       (format *trace-output* 
		       
#-acl3.0"~%Created evaluable patch file of some choosers of region ~30<~A~>. ~
~20<(~a choosers)~>" 
#+acl3.0"~%Created evaluable patch file of some choosers of region ~30<~A~>.
~20<(~a choosers)~>" 

	      region (length chooser-list))
	(format *trace-output* 

#-acl3.0"~%Created evaluable file for    choosers of region    ~30<~A~>. ~
~20<(~a choosers)~>" 
#+acl3.0"~%Created evaluable file for    choosers of region    ~30<~A~>. 
~20<(~a choosers)~>" 
		   region (length chooser-list))))
	  (t
	   (push region *regions-with-no-choosers*)
	   (unless *saving-patches-mode*
	     (format *trace-output* "~%No choosers in region: ~A." region))))))


;-------------------------------------------------------------------------
; Inquiries

(defun CREATE-INQUIRIES-OF-REGION-FILE (region file-pathname 
					       &key 
					       (ml nil)
					       (inheriting-from curlan)
					       (inheriting-to curlan)
					       (concerned-languages nil))
  (let ((inquiry-list nil)
	(old-curlan curlan)
	(inq-count 0))
    (when inheriting-from (setf curlan inheriting-from))
    (unless concerned-languages (setf concerned-languages all_languages))

    (setf inquiry-list
      (if ml 
	  (inquiries-of-region-of-languages region concerned-languages)
	(append (ask-inquiries-of-region region) 
		(identify-inquiries-of-region region))))
    (when (where-am-i-id-appropriate-p ml region concerned-languages)
      (pushnew 'where-am-i-id inquiry-list))
    
    (when *saving-patches-mode*
      (setf inquiry-list
	(select-patched-inquiries inquiry-list concerned-languages)))

    (setf inq-count (length inquiry-list))

    (cond (inquiry-list
	   (write-inquiry-operators file-pathname inquiry-list
				    :ml ml
				    :region-specified region
				    :lg-specified inheriting-to)
	   (setf curlan old-curlan)
	   (if *saving-patches-mode*
	       (format *trace-output* 
		  
#-acl3.0"~%Created evaluable patch file of some inquiries of region ~30<~A~>. ~
~20<(~a inquiries)~>" 
#+acl3.0"~%Created evaluable patch file of some inquiries of region ~30<~A~>. 
~20<(~a inquiries)~>" 
		  region inq-count)
	     (format *trace-output* 
		     
#-acl3.0"~%Created evaluable file for      inquiries of region ~30<~A~>. ~
~20<(~a inquiries)~>" 
#+acl3.0"~%Created evaluable file for      inquiries of region ~30<~A~>. 
~20<(~a inquiries)~>" 

		     region  inq-count)))
	  (t
	   (push region *regions-with-no-inquiries*)
	   (unless *saving-patches-mode*
	     (format *trace-output* 
		     "~%No inquiries in region: ~A." region))))))

;;;-------------------------------------------------------------------------

;;; Now we bottom out to the individual functions for writing
;;; out types of linguistic objects. These all now use the generic
;;; systemic display function, simply providing an appropriate
;;; stream for output and the specification of whether the
;;; output form should be multilingual or not. Conditionalization
;;; according to region focusing also comes in. The previous
;;; definitions were in the KPML-extended version of object-management.lisp.

;;; The keyword arguments have the following effects...
;;;   ml -- results in multilingual definitions (i.e.,
;;;         CONDITIONALIZED) being output if these are present, (if
;;;         the multilingual environment is not present, then this just
;;;         produces old Penman-style definitions.)  If nil, then definitions
;;;         appropriately conditionalized for the locally current language are
;;;         given. In other words, ml=T causes the full internal
;;;         definition to be given, whatever that might be, while
;;;         ml=nil will attempt to extract a language specific view.
;;;  region-specified -- defines the region of the resources (for use in
;;;         in-region declarations).
;;;  lg-specified -- for use in in-language declarations.
;;;  ls -- for specifying language locally.
;;;
;;;;
  ;;
  ;; 4.0 XML added by moving declarations out into parameterized 
  ;;         methods.

(defun WRITE-SYSTEMS (file-name system-list
				&key 
				(ml nil)
				(region-specified nil)
				(lg-specified nil)
				(ls curlan))
  (let ((path (if (pathnamep file-name) file-name
		(pathname file-name)))
	(display-mode (if ml :multilingual :monolingual))
	(language-set (if ml *languages-in-focus* ls)))
    (with-open-file 
     (stream (merge-pathnames path (user-homedir-pathname))
	     :direction :output
	     :if-exists :new-version)
     (print-opener :systems stream)
     (print-mode-and-copyright stream)
     (when region-specified (print-region-declaration region-specified stream))
     (unless (eq display-mode :multilingual)
	     (when lg-specified (print-lg-declaration lg-specified stream)))
     (dolist (system (sort system-list #'string<))
	     (systemic-display system
			       :object-type :system
			       :stream stream
			       :display-mode display-mode
			       :languages language-set))
     (print-closer :systems stream))))


  ;; 4.0 XML added by moving declarations out into paramterized 
  ;;         methods.
  ;;
(defun WRITE-CHOOSERS (file-name chooser-list
				&key 
				(ml nil)
				(region-specified nil)
				(lg-specified nil)
				(ls curlan))
  (let ((path (if (pathnamep file-name) file-name
		(pathname file-name)))
	(display-mode (if ml :multilingual :monolingual))
	(language-set (if ml *languages-in-focus* ls)))

    (with-open-file 
     (stream (merge-pathnames path (user-homedir-pathname))
	     :direction :output
	     :if-exists :new-version)
     (print-opener :choosers stream)
     (print-mode-and-copyright stream)
     (when region-specified (print-region-declaration region-specified stream))
     (unless (eq display-mode :multilingual)
       (when lg-specified (print-lg-declaration lg-specified stream)))
     (dolist (chooser (sort chooser-list #'string<))
	     (systemic-display chooser
			       :object-type :chooser
			       :stream stream
			       :display-mode display-mode
			       :languages language-set))
     (print-closer :choosers stream))))


  ;; 4.0 XML added here too...
  ;;
(defun WRITE-INQUIRY-OPERATORS 
  (file-name inquiry-list
	     &key
	     (ml nil)
	     (region-specified nil)
	     (lg-specified nil)
	     (ls curlan))

  (let ((path (if (pathnamep file-name) file-name
		(pathname file-name)))
	(display-mode (if ml :multilingual :monolingual))
	(language-set (if ml *languages-in-focus* ls))
	originating-region commenting)
    (with-open-file 
     (stream (merge-pathnames path (user-homedir-pathname))
	     :direction :output
	     :if-exists :new-version)
     (print-opener :inquiries stream)
     (print-mode-and-copyright stream)
          (when region-specified (print-region-declaration region-specified stream))
     (unless (eq display-mode :multilingual)
       (when lg-specified (print-lg-declaration lg-specified stream)))
     (case *object-output-mode*
	   (:ascii 
	    (dolist (key (sort inquiry-list #'string<))
		    (cond ((assoc key *inquiry-definitions-given*)
			   (setf originating-region 
				 (second 
				  (assoc key *inquiry-definitions-given*)))
			   (message "Inquiry definition " key 
				    " used in region " region-specified 
				    " has already been defined in region "
				    originating-region)
			   (format stream 
				   "~%;;; Definition ~S already provided in region ~S "
				   key originating-region)
			   (format stream "~%#|~%")
			   (setf commenting t))
			  (t 
			   (push (list key region-specified) 
				 *inquiry-definitions-given*)))
		    (systemic-display key
				      :object-type :inquiry
				      :stream stream
				      :display-mode display-mode
				      :languages language-set)
		    (when commenting 
		      (format stream "~%|#~2%")
		      (setf commenting nil))))
	   (:xml
	    (dolist (key (sort inquiry-list #'string<))
		    (cond ((assoc key *inquiry-definitions-given*)
			   (format stream 
				   "~%<!-- Definition ~S already provided in region ~S ... "
				   key (second 
					(assoc key *inquiry-definitions-given*)))
			   (setf commenting t))
			  (t 
			   (push (list key region-specified) 
				 *inquiry-definitions-given*)))
		    (systemic-display key
				      :object-type :inquiry
				      :stream stream
				      :mode :xml
				      :display-mode display-mode
				      :languages language-set)
		    (when commenting 
		      (format stream " -->~%")
		      (setf commenting nil)))))
     (print-closer :inquiries stream)
     )))


;;; ----------------------------------------------------------------------

;;; A couple of extras to help along...

(defun SYSTEMS-OF-REGION-OF-LANGUAGES (region concerned-languages)
  (let ((regions (get-regions t)))
    (cond ((not (member region regions))
	   (format t "Requested region: ~A does not have any systems in it.~%" 
		   region)
	   nil)
	  (t
	   (sort (remove-duplicates
		  (loop for system in (list-systems) 
		        when
		        (loop for lg in concerned-languages
			      thereis 
			      (and (system-defined-for-lg-p system lg)
				   (eq (fetch-system-region system lg) region)))
		       collect system))
		 #'string-lessp)))))


(defun CHOOSERS-OF-REGION-OF-LANGUAGES (region concerned-languages)
  (let ((relevant-choosers nil)
	(old-curlan curlan))
    (loop for lg in concerned-languages do
	  (setf curlan lg)
	  (loop for r in (choosers-of-region region :no-warning-p T) do
		(pushnew r relevant-choosers)))
    (setf curlan old-curlan)
    relevant-choosers))

(defun INQUIRIES-OF-REGION-OF-LANGUAGES (region concerned-languages)
  (let ((relevant-inquiries nil)
	(old-curlan curlan))
    (loop for lg in concerned-languages do
	  (setf curlan lg)
	  (loop for r in (ask-inquiries-of-region region
						  :no-warning-p T) do
		(pushnew r relevant-inquiries))
	  (loop for r in (identify-inquiries-of-region 
			  region :no-warning-p T) 
		do
		(pushnew r relevant-inquiries)))
    (setf curlan old-curlan)
    relevant-inquiries))

	  




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ordering constraints and punctuation: Revised version.
;     KPML 0.8; further revision: form of defaults changed
;               and made minimally multilingual; relies on
;                 ml-default-orderings.lisp
;                 ml-system-dependencies.lisp
;                 ml-punctuation.lisp
;               if to be used multilingually.
;       Since the old forms (i.e., Penman-style) can still be loaded
;       the following also provides access to a conversion capability. Simply
;       read the old form, and then write a monolingual set of files
;       for the desired language. Unless the (ml-p) predicate returns
;       NIL (i.e., we are not running under KPML) these write functions
;       will here enforce multilingual definitions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; NOTE: NOT YET ABLE TO PRODUCE ARBITRARY MULTILINGUAL (I.E. SUBSETS
;;;       OF ALL_LANGUAGES) DEFINITIONS!!!
;;;  that is, there is no checking of *languages-in-focus*, it is
;;;  assumed that all languages will be given, and therefore it
;;;  is sufficient just to give the values of the global variables.
;;;  Need, when ml is set, to additionally check *languages-in-focus*.
;---------------------------------------------------------------------------
; ordering constraints....

(defun WRITE-ORDERING-CONSTRAINTS (file-pathname 
				   &key 
				   (ml nil)
				   (inheriting-from curlan)
				   (inheriting-to curlan)
				   (concerned-languages nil))
  (let ((old-curlan curlan))
    (when inheriting-from (setf curlan inheriting-from))
    (unless concerned-languages (setf concerned-languages all_languages))

    (create-ordering-constraints-file file-pathname 
				      :ml ml :languages concerned-languages
				      :lg-specified inheriting-to)
    (format *trace-output* 
	    "~%Created evaluable default ordering file.")
    (setf curlan old-curlan)))


;  0.8: name changed from write-ordering-constraints and made multilingual... 
;       when ml is set, produces a single file for all the loaded
;       resources (which is the old behavior if this code is not
;       used multilingually!); otherwise, produces a file just for
;       curlan (but labelled as for lg-specified).
;
(defun CREATE-ORDERING-CONSTRAINTS-FILE 
  (root-directory &key
		  (ml nil)(languages all_languages)
		  (lg-specified nil))

  (with-open-file (stream (merge-pathnames (pathname root-directory) 
					   (pathname "ordering-constraints.gram"))
			  :direction :output
			  :if-exists :new-version)
    (print-mode-and-copyright stream)
    (when (and (ml-p) (not lg-specified)) (setf lg-specified curlan))
 
    (when (ml-p)
	  (unless (eq (first system-dependencies) :multilingual)
		  (make-kpml-conforming-dependency-sets))
	  (unless (eq (first fragment-order-lsts) :multilingual)
		  (make-kpml-conforming-default-orderings)))

;;; the default orderings...
    (cond (ml
	   (unless (set-equal languages all_languages)
		   (warning "Multilingual selections for fragment ordering not yet present; taking all languages"))
	   (format stream "~2%(setq fragment-order-lsts '~S)"
		   fragment-order-lsts))
	  (t
	   (format stream "~2%(define-default-orders :language ~S
         :orders '~S)" lg-specified (ml-default-orderings))))

;;; the system dependencies...

    (cond ((and ml (ml-p))   ;; multilingual definitions to be given...
	   (unless (set-equal languages all_languages)
		   (warning "Multilingual selections for system dependencies not yet present; taking all languages"))
	   
	   (format stream
		   "~%(defvar *system-dependency-sets*)~%(setf *system-dependency-sets* '~S)" *system-dependency-sets*)
	   (format stream
		   "~2%(setq System-Dependencies '~S) ~3%" 
		   System-Dependencies ))

	  (ml                ;; this is the old code (KPML 0.7 and before)
	   (format stream 
		   "~%(defvar *ordering-regions*) ~% (setf *ordering-regions* '~a)" *ordering-regions*)
	   (dolist (ordering-region *ordering-regions*)
		   (format stream
			   "~2%(defvar ~a)~%(setq ~a '~S)" 
			   ordering-region ordering-region 
			   (kpml-eval ordering-region)))
	   (format stream 
		   "~2%(setq System-Dependencies '~S) ~3%" 
		   System-Dependencies )
	   )

	  (t                ;; single language view on multilingual resources
	   (dolist (depset *system-dependency-sets*)
		   (when (eq (first (second depset)) curlan)
			 (format stream
				 "~2%(define-dependency-set
   :language ~S
   :name ~S
   :systems-list '~S)"
				 lg-specified 
				 (first depset) (second (second depset))
				 )))
	   (format stream
		   "~2%(define-system-dependencies
   :language ~S
   :dependencies '~S)"
		   lg-specified (ml-system-dependencies))))
    ))



;;; --------------------------------------------------
;;; Multilingual punctuation.
; 
;;; Same as for dependencies and default orderings. Automatic
;;; conversion when called with KPML 0.7- and Penman-style
;;; punctuation rules loaded.

(defun WRITE-PUNCTUATION (file-pathname 
			  &key 
			  (ml nil)
			  (inheriting-from curlan)
			  (inheriting-to curlan)
			  (concerned-languages nil))
  (let ((old-curlan curlan))
    (when inheriting-from (setf curlan inheriting-from))
    (unless concerned-languages (setf concerned-languages all_languages))

    (create-punctuation-rules-file file-pathname 
				   :ml ml :languages concerned-languages
				   :lg-specified inheriting-to)
    (format *trace-output* 
	    "~%Created evaluable punctuation rule file.")
    (setf curlan old-curlan)))


;; 4.0 pre-Self punctuation added...
;;
(defun CREATE-PUNCTUATION-RULES-FILE (root-directory
				      &key 
				      (ml nil)
				      (languages all_languages)
				      (lg-specified nil))

  (with-open-file (stream (merge-pathnames (pathname root-directory)
					   (pathname "punctuation.gram"))
			  :direction :output
			  :if-exists :new-version)
    (print-mode-and-copyright stream)

    (when (ml-p)
	  (unless (eq (first *pre-punctuation*) :multilingual)
		  (make-kpml-conforming-punctuation-rules)))

    (cond ((and ml (ml-p)) ;; multilingual definitions to be given
	   (unless (set-equal languages all_languages)
		   (warning "Multilingual selections for punctuation rules not yet present - taking all languages; edit down by hand if necessary"))
	   
	   (format stream  
		   "~2%(setf *pre-punctuation* '~S )" *pre-punctuation*)
	   (format stream  
		   "~2%(setf *post-punctuation*  '~S )" *post-punctuation*)
	   (format stream  
		   "~2%(setf *post-self-punctuation* '~S )" 
		   *post-self-punctuation*)
	   ;; 4.0 added...
	   (format stream  
		   "~2%(setf *pre-self-punctuation* '~S )" 
		   *pre-self-punctuation*)
	   )

	  (ml       ;; the old KPML 0.7- code...
	            ;; This writes out Penman-style punctuation rules.
	   (format stream  
		   "~2%(setf *pre-punctuation* '( ~{~%~4T(~{~50@<~a~> ~20<~a~> ~6<~s~>~}) ~}))" *pre-punctuation*)
	   (format stream  
		   "~2%(setf *post-punctuation* '( ~{~%~4T(~{~50@<~a~> ~20<~a~> ~6<~s~>~}) ~}))" *post-punctuation*)
	   (format stream  
		   "~2%(setf *post-self-punctuation* '( ~{~%~4T(~{~50@<~a~> ~20<~a~> ~6<~s~>~}) ~}))" *post-self-punctuation*)
	   ;; 4.0: not sure if this code is ever used and under what circumstances... but
	   ;;      give a warning if we find ourselves here...
	   (when *pre-self-punctuation*
	     (warning "Attempt to write Penman-style punctuation rules when pre-self punctuation defined. Penman cannot interpret this kind of punctuation rule. Please check why this style of punctuation rule is being used and change to KPML-style if possible."))
	   )
	  
	  (t        ;; extraction of single language punctuation rules...
	   (format stream "~2%(define-pre-punctuation :language ~S
         :punctuation-rules '~S)" lg-specified (ml-pre-punctuation))
	   (format stream "~2%(define-post-punctuation :language ~S
         :punctuation-rules '~S)" lg-specified (ml-post-punctuation))
	   (format stream "~2%(define-post-self-punctuation :language ~S
         :punctuation-rules '~S)" lg-specified (ml-post-self-punctuation))
	   ;; 4.0
	   (format stream "~2%(define-pre-self-punctuation :language ~S
         :punctuation-rules '~S)" lg-specified (ml-pre-self-punctuation))))
    ))



;;; ----------------------------------------------------------------------
;;; Lexical items...
;;;
;;; Lexical items are written out to files with the same names as
;;; those from which they were loaded. If a lexical item has no
;;; associated source file (for example, it may have been typed
;;; in directly somewhere and evaluated), then it is output to
;;; a file "lexicon.lexicon" (appending to that file!). If the
;;; acquire lexical items flag is set, then the new lexical items
;;; are written to a file "new-lexicon.lexicon" (appending to
;;; that file!). 

;;; Two extra options may be provided sometime by functions such as:
;;;   make-new-open-class-lexicon-file -- takes lexical items
;;;                                       that are not used in the
;;;                                       grammar and writes these
;;;                                       sorted to a new file as
;;;                                       named.
;;;   make-new-closed-class-lexicon-file -- same for items used in
;;;                                       the grammar.
;;;
;;; 4.0 XML added on the model of all other linguistic objects, previous
;;;     experimental code from 2002 taken out.
;;;

(defun SAVE-LEXICON-FILES-TO-DIRECTORY 
  (directory ml inheriting-from inheriting-to)
  (let ((lexitem-list nil)
	(old-curlan curlan))
    (when inheriting-from
	  (setf curlan inheriting-from))
    (setf lexitem-list 
	  (if ml 
	      (filter-terms-by-languages
	       (hashtable-to-list lexicon)
	       (if *languages-in-focus*
		   *languages-in-focus*
		 all_languages))
	    (list-lexical-items curlan)))
    (if lexitem-list
	(progn
	  (write-lexical-items directory lexitem-list
			       :ml ml
			       :lg-specified inheriting-to)
	  (format *trace-output* 
		       "~%Created evaluable files for ~A lexical items." 
		       (length lexitem-list)))
      (format *trace-output* "No relevant lexical items found."))
    (setf curlan old-curlan)))
				       
(defun WRITE-LEXICAL-ITEMS (lg-root-directory lexitem-list
					      &key 
					      (ml nil)(lg-specified nil)
					      (ls curlan))
  (let ((lexitem-source-files nil)
	(path (if (pathnamep lg-root-directory) lg-root-directory
		(pathname lg-root-directory)))
	(display-mode (if ml :multilingual :monolingual))
	(language-set (if ml *languages-in-focus* ls))
	(unassociateds? nil)
	(lexitem-file-pairs (make-hash-table :size (length lexitem-list))))
    
    (loop for lexitem in lexitem-list 
          do
	  (if (let ((source (lexical-item-source-file 
			     (gethash lexitem lexicon))))
		(and source
		     (not (and (stringp source)
			       (string= source "")))))
	      (let ((file 
		     (pick-a-source-lexicon-file lexitem ml language-set)))
                ;; 2.1 under LW4.0 the following can somehow be met... not sure how or why...
                (if (string= (file-namestring file) "")
                    (setf unassociateds? T)
                  (progn
		    (setf (gethash lexitem lexitem-file-pairs) file)
		    (pushnew file lexitem-source-files :test #'equal))))
            (setf unassociateds? T)))
    (loop for source-file in lexitem-source-files 
          do
	  (with-open-file (stream (merge-pathnames 
				   (typed-lexicon-file-name
				    (file-namestring source-file))
				   (merge-pathnames 
				    (concatenate 'string 
						 "Lexicons"
						 (string *directory-delimiter*))
				    path))
				  :direction :output :if-exists :new-version)
			  ;; 4.0
			  ;;      new standard XML compatible prelude
			  ;;
			  (print-opener :lexemes stream)      
			  (print-mode-and-copyright stream)   
			  (unless (eq display-mode :multilingual)
			    (when lg-specified (print-lg-declaration lg-specified stream)))
			  (systemic-display-items 
			   lexitem-list
			   :test #'(lambda (item)
				     (equal 
				      (gethash item lexitem-file-pairs)
				      source-file))
			   :object-type :lexeme :stream stream
			   :display-mode display-mode
			   :languages language-set)
			  (print-closer :lexicon stream))
	  )
    (when unassociateds?
      (with-open-file 
       (stream (merge-pathnames 
		(typed-lexicon-file-name "lexicon.lexicon")
		(merge-pathnames 
		 (concatenate 'string "Lexicons" 
			      (string *directory-delimiter*))
		 path))
	       :direction :output :if-exists :append
	       :if-does-not-exist :create)
       
       ;; 4.0
       ;;      new standard XML compatible prelude
       ;;
       (print-opener :lexemes stream)      
       (print-mode-and-copyright stream)   
       (unless (eq display-mode :multilingual)
	 (when lg-specified (print-lg-declaration lg-specified stream)))

       (systemic-display-items 
	lexitem-list
	:test #'(lambda (item) 
		  (null (gethash item lexitem-file-pairs)))
	:object-type :lexeme
	:stream stream :display-mode display-mode 
	:languages language-set)
       (print-closer :lexicon stream)))))





;;; Following was also not Allegro CLtL2 compatible... can't send
;;; nil to pathname-name.

(defun PICK-A-SOURCE-LEXICON-FILE (lexitem ml language-set)
  (cond ((not ml)
	 (fetch-lexicon-info lexitem 'source-file))
	(t
	 (let* ((lgset (if language-set language-set
			 all_languages))
		   (path nil)
		   (names 
		    (remove-duplicates
		     (loop for lg in lgset
			 when (setf path (fetch-lexicon-info 
					  lexitem 
					  'source-file lg))
			 collect
			   (concatenate 'string 
			    (pathname-name path)
			    "."
			    (pathname-type path)))
		     :test #'string=)))

	   (if (eq (length names) 1)
	       (pathname (first names))
	     (typed-lexicon-file-name (pathname "merged-lexicon.lexicon")))))))


;; ......................................................................
;; 4.0
;;  following nasty makes sure that we have a file name with the
;;  appropriate extension for accessing lexicon files depending on
;;  whether they are to be written in XML or trad KPML.
;;  Assumes that KPML wants to write to some traditionally named
;;  lexicon file and hijacks this if XML mode is set so that
;;  the extension is changed.
;;
(defun TYPED-LEXICON-FILE-NAME (pathname)
  (case *object-output-mode*
	(:ascii pathname)
	(:xml
	 (let ((p (if (pathnamep pathname) pathname (pathname pathname))))
	   (merge-pathnames (pathname-name p) ".xlx")))))


;;; ======================================================================
;;; EXAMPLES...
;;;
;;; ... and virtually the same for examples...

;;; 0.9.62 duplicated examples could be written out...
(defun SAVE-EXAMPLE-FILES-TO-DIRECTORY 
  (directory ml inheriting-from inheriting-to)
  (let ((example-list nil)
	(old-curlan curlan))
    (when inheriting-from
	  (setf curlan inheriting-from))
    (setf example-list 
      (remove-duplicates   ;; 0.9.62
       (if ml
	   (examples-of-languages 
	    (if *languages-in-focus* *languages-in-focus* all_languages))
	 (list-of-examples))))
    (if example-list
	(progn
	  (write-example-files directory example-list
			       :ml ml
			       :lg-specified inheriting-to)
	  (format *trace-output* 
		  "~%Created evaluable files for ~A examples." 
		  (length example-list)))
      (format *trace-output* "~%No relevant examples found."))
    (setf curlan old-curlan)))


;;; ----------------------------------------------------------------------
;;; 0.8.17 avoids multiple file writing due to wrong equality test.
;;; 2.0.4 
;;;   Previously was not using the example set name to save example
;;;   sets whenever there was no file name associated. This is not
;;;   what was intended, corrected here so that the example set name
;;;   takes precedence...
;;; 2.1
;;;   order of written examples updated.
;;; 3.2.21 
;;;   Explicit external format for the exset report files.
;;; 4.0 
;;;   XML export added
;;; ----------------------------------------------------------------------

(defun WRITE-EXAMPLE-FILES
  (lg-root-directory example-list 
		     &key
		     (ml nil)
		     (lg-specified nil)
		     (ls curlan))
  
  (let ((example-source-files nil)
        ;; 2.1 ordering changed to be more appropriate...
        (example-list (sort example-list #'numbered-name-lessp))
	(path (if (pathnamep lg-root-directory) lg-root-directory
		(pathname lg-root-directory)))
	(display-mode (if ml :multilingual :monolingual))
	(language-set (if ml *languages-in-focus* ls))
	(unassociateds? nil)
	(example-file-pairs (make-hash-table :size (length example-list))))
    
    (loop for example in example-list do
	  (if (or (let ((source (example-source-file 
				     (gethash example penexamples))))
		    (and source	
			 (not (and (stringp source)
				   (string= source "")))))
		  
		  (fetch-example-info example 'set-name))
	      (let ((file 
		     (pick-a-source-example-file example ml language-set)))
		(setf (gethash example example-file-pairs) file)
		(pushnew file example-source-files :test #'equal))
	    (setf unassociateds? T)))
    (loop for source-file in example-source-files do
	  (with-open-file (stream (merge-pathnames 
				   (file-namestring source-file)
				   (merge-pathnames 
				    (concatenate 
				     'string "Examples" 
				     (string *directory-delimiter*))
				    path))
				  :direction :output :if-exists :new-version
				  #+lispworks
				  :external-format  		 ;; 3.2.21 
				  #+lispworks
				  (file-encoding kpml::curlan))
			  ;; 4.0
			  ;;      new standard XML compatible prelude
			  ;;
			  (print-opener :examples stream)      
			  (print-mode-and-copyright stream)   
			  (unless (eq display-mode :multilingual)
			    (when lg-specified (print-lg-declaration lg-specified stream)))
			  (systemic-display-items 
                           example-list
			   :test #'(lambda (item)
				     (equal 
				      (gethash item example-file-pairs)
				      source-file))
                           :sort nil
			   :object-type :example :stream stream
			   :display-mode display-mode
			   :languages language-set)
			  (print-closer :examples stream)))
    (when unassociateds?
	  (with-open-file 
	   (stream (merge-pathnames 
		    "examples.spl" (merge-pathnames 
				    (concatenate 
				     'string "Examples" 
				     (string *directory-delimiter*))
				    path))
		   :direction :output :if-exists :append
		   :if-does-not-exist :create)
	   ;; 4.0
	   ;;      new standard XML compatible prelude
	   ;;
	   (print-opener :examples stream)      
	   (print-mode-and-copyright stream)   
	   (unless (eq display-mode :multilingual)
	     (when lg-specified (print-lg-declaration lg-specified stream)))
	   
	   (systemic-display-items 
	    example-list
	    :test #'(lambda (item) 
		      (null (gethash item example-file-pairs)))
	    :object-type :example
	    :stream stream :display-mode display-mode 
	    :languages language-set)
	   (print-closer :examples stream)))
    ))



;;; same bug as pick a source lexicon file...
;;; 4.0 extended to provide different file names according to whether XML mode is
;;;     is on or not...

(defun PICK-A-SOURCE-EXAMPLE-FILE (example ml language-set)
  (cond ((not ml)
	 (if (fetch-example-info example 'set-name)
	     (ecase *object-output-mode*
		    (:ascii
		     (concatenate 'string
				  (string (fetch-example-info example 'set-name))
				  ".spl"))
		    (:xml
		     (concatenate 'string
				  (string (fetch-example-info example 'set-name))
				  "-spl"
				  ".xml")))
	   (fetch-example-info example 'source-file)))
	(t
	 (let* ((lgset (if language-set language-set
			 all_languages))
		   (path nil)
		   (names 
		    (remove-duplicates
		     (loop for lg in lgset
			 if (fetch-example-info example 'set-name lg)
			 collect  (ecase *object-output-mode*
					 (:ascii
					  (concatenate 'string
						       (string
							(fetch-example-info example 'set-name lg))
						       ".spl"))
					 (:xml
					  (concatenate 'string
						       (string
							(fetch-example-info example 'set-name lg))
						       "-spl"
						       ".xml")))
			 else
			 if (setf path (fetch-example-info 
					example
					'source-file lg))
			 collect
			 (ecase *object-output-mode*
				(:ascii
				 (concatenate 'string
					      (pathname-name path)
					      "."
					      (pathname-type path)))
				(:xml
				 (concatenate 'string
					      (pathname-name path)
					      "-"
					      (pathname-type path)
					      ".xml"
					      ))))
		     :test #'string=)))
	   (if (eq (length names) 1)
	       (pathname (first names))
	     (ecase *object-output-mode*
		    (:ascii
		     (pathname "merged-examples.spl"))
		    (:xml
		     (pathname "merged-examples-spl.xml"))
		    ))))))


	   

;;; ----------------------------------------------------------------------
;;; Inquiry implmentations can be in different packages...
;;;
;;; Package setting behavior...
;;    if target
;;	penman > target
;;        not-penman > stays as is unless forced.       
;;     if not-target
;;        stays as is.

(defun IN-INQUIRY-PACKAGE (function-name-symbol &optional (lg curlan))
  (let ((target-package
	 (cond ((stringp *package-for-inquiry-implementations*)
		*package-for-inquiry-implementations*)
	       ((keywordp *package-for-inquiry-implementations*)
		(string *package-for-inquiry-implementations*))
	       ((consp *package-for-inquiry-implementations*)
		(cdr (assoc lg
			    *package-for-inquiry-implementations*)))
	       (t nil)))
	(original-package
	 (package-name (symbol-package function-name-symbol))))
    
    (if (and target-package
	     (or
	      (string= original-package "KPML")
	      *force-inquiry-implementation-package?*))
	(format nil "~A::~A" target-package function-name-symbol)
      (format nil "~A::~A" original-package function-name-symbol))))


;;; Following function is very similar; it is called when we are
;;; in multilingual writing mode and the value to be written is
;;; a list of language conditions and interspersed inquiry code
;;; names. This can only be done properly if we know which
;;; inquiry package is associated with each language. Thus,
;;; we construct a list consisting of the operatorcode for
;;; each language for which the inquiry is defined. 

(defun IN-ML-INQUIRY-PACKAGES (ml-operator-code-spec lgs)
  (let ((lg-code-spec-pair-list
	 (flatten
	  (loop for lg in lgs
		collect 
		(list lg (in-inquiry-package 
			  (strip-lx 
			   (parse-clause ml-operator-code-spec lg))))))))
    (mapcar #'(lambda (x)
		(if (keyword-p x)
		    (format nil "~S" x)
		  x))
	    (kpml-eval `(merge-lx ,@lg-code-spec-pair-list)))))



;;; ----------------------------------------------------------------------
;;; KPML 0.8 adds the default environment definitions for SPL into
;;; the standard resources loaded... (That is they are loaded, but
;;; *not* activated, since during resource loading we may not yet
;;; have decided what curlan is...)
;;; 2.1 make sure that curlan keeps in step with what is required...
;;; ----------------------------------------------------------------------

(defun LOAD-INQUIRY-DEFAULT-DEFINITIONS-FROM-DIRECTORY 
  (language lg-root-directory)
  (let* ((spl-macros
	  (merge-pathnames 
	   (pathname lg-root-directory)  "basic-spl-macros.lisp"))
	 (spl-macros? (open spl-macros :direction :probe))
	 (spl-defaults
	  (merge-pathnames 
	   (pathname lg-root-directory)  "basic-spl-defaults.lisp"))
	 (spl-defaults? (open spl-defaults :direction :probe)))

    ;; 2.1 make sure that the keyword recognition is uptodate (even across
    ;;     a range of languages)...
    (setup-spl-keywords-over-language-range)
    (when spl-macros? 
      (format *trace-output* "~%;;; Loading SPL macros for variety: ~A" 
	      language)
      (kpml-load spl-macros))

    ;; 2.1 curlan must be set to an appropriate valie when loading
    ;;     default definitions...
    (when spl-defaults?
      (let ((curlan (if *current-language-range* 
			(first *current-language-range*)
		      curlan)))
	(format *trace-output* 
		"~%;;; Loading SPL defaults for variety: ~A " language)
	(unless (equal language curlan)
	  (format *trace-output* 
		  "~%;;; .... (with current variety set to ~A)" curlan))
	(kpml-load spl-defaults)))
    ))

(defun LOAD-SPL-DEFAULTS-AND-MACROS (language &key (merge *merging-active*))
  (let* ((*merging-active* merge)
	 (lg-name (string language))
	 (lg-root-directory 
	  (pathname
	   (coerce-directory
	    (merge-pathnames common-lisp-user::*root-of-resources* lg-name)))))
    (load-inquiry-default-definitions-from-directory 
     language lg-root-directory)))


;;; ----------------------------------------------------------------------
(defun SAVE-LANGUAGE-PROPERTIES-TO-DIRECTORY 
  (directory ml inheriting-from inheriting-to)
  (let ((curlan (if inheriting-from inheriting-from
		  curlan))
	(concerned-languages (if *languages-in-focus* *languages-in-focus*
			       all_languages)))
    (create-properties-file directory 
			    :ml ml
			    :lg-specified inheriting-to
			    :languages concerned-languages)
    (format *trace-output* 
	    "~%Created evaluable properties file." )))


;;; ----------------------------------------------------------------------
;;; 0.9.59: Automatic writing of font selection information in the
;;;         properties file added.
;;; 1.0.24: string clean-ups added.
;;; 2.0     Language abbreviations added.
;;; 2.0.53  Language conditionalization missed at one point.
;;; 3.2     Duplication removed to reduce chance of error and ease updates
;;; 3.2.22  Font declaration moved to language-range file in saves.
;;; ----------------------------------------------------------------------

(defun CREATE-PROPERTIES-FILE (root-directory
			       &key (ml nil)(lg-specified curlan)
			       (languages all_languages))
  (macrolet ((write-declarations (lg)
              `(progn
		 (write-language-description-declarations stream ,lg)  ;; 3.2
		 (write-morphology-declarations stream ,lg)
		 (write-standard-defaults stream ,lg)
		 ;; 3.2 missed for ml case
		 (write-standard-abbreviations stream ,lg)  
		 ;; 3.2.22 font declarations not done here anymore...
		 (write-string-cleanup-declarations stream ,lg)    ;; 1.0.24
		 (write-disabled-system-list stream ,lg) 	   ;; 2.0.53
		 )))
      (with-open-file (stream (merge-pathnames (pathname root-directory)
					       (pathname "properties.lisp"))
			      :direction :output
			      :if-exists :new-version)
	(print-mode-and-copyright stream)
	(if ml
	    (dolist (curlan languages) (write-declarations curlan))
	  (write-declarations lg-specified)))))

;;; 3.2 updated to write generator-file info too...
;;;
(defun WRITE-MORPHOLOGY-DECLARATIONS (stream lg-specifier)
  (let ((lg-decl (assoc curlan *language-morphology-profiles*)))
    (format stream "~2%(define-language-morphology-requirements :language ~S" lg-specifier)
    (format stream "~%    :systemicized ~S" (second lg-decl))
    (when (third lg-decl) (format stream "~%    :generator-fn ~S" (third lg-decl)))
    (when (fourth lg-decl) (format stream "~%    :generator-file ~S"  (fourth lg-decl)))
    (format stream "~%    )")))

(defun WRITE-STANDARD-DEFAULTS (stream lg-specifier)
  (let ((lg-decl (assoc curlan *language-standard-defaults*)))
    (format stream "~2%(define-language-standard-defaults
  :language ~S :defaults ~S)" lg-specifier (second lg-decl))))
	    
;;; 2.0
(defun WRITE-STANDARD-ABBREVIATIONS (stream lg-specifier)
  ;; 2.0.27 silly mistake out.
  (let ((lg-abbrev (cdr (assoc curlan *contrastive-labels*))))
    (when lg-abbrev
      (format stream "~2%(define-language-standard-abbreviation
  :language ~S :abbreviation ~A)" lg-specifier lg-abbrev))))

(defun WRITE-DISABLED-SYSTEM-LIST (stream lg-specifier)
  (dolist (system (disable-system))
	  (format stream
		  "~2%(disable-system ~S ~S)"
		  system lg-specifier)))
		  

;;; ----------------------------------------------------------------------

(defun SAVE-UNCONDITIONALIZED-LINGUISTIC-RESOURCES
  (variety-designation &optional
		       &key
		       (root-directory common-lisp-user::*root-of-resources*)
		       (inquiry-package nil))
  (setf *no-ml-conditionalization* T)
  (unwind-protect
      (block nil
	     (save-linguistic-resources variety-designation 
					:root-directory root-directory
					:inquiry-package inquiry-package)))
  (setf *no-ml-conditionalization* NIL))



;;; Modelled on write-morphology-declarations...
;;; 3.2 extended to write code-pages...
;;; 3.2.7 code-page variable was still in wrong package here...

(defun WRITE-LANGUAGE-FONT-DECLARATIONS (stream lg-specifier)
  (let ((lg-fonts (assoc curlan *language-font-profiles*)))
    (when lg-fonts
      (format stream "~2%(define-language-font-requirements  :language ~S" lg-specifier)
      (format stream "~%      :inspector ~S" (second lg-fonts))
      (format stream "~%      :popup ~S"   (third lg-fonts))
      (when (assoc lg-specifier *code-page-language-associations*)
	(format stream "~%      :code-page ~S" 
		(second 
		 (assoc lg-specifier *code-page-language-associations*))))
      (format stream "~%    )"))))

;;; 3.2 new...
;;;
(defun WRITE-LANGUAGE-DESCRIPTION-DECLARATIONS (stream lg-specifier)
  (let ((lg-description (assoc curlan *language-description-profiles*)))
    (when lg-description
      (format stream "~2%(define-language-description  (:language ~S :style ~S)" 
	      lg-specifier (second lg-description))
      (format stream "~{~%    ~S~}"   (third lg-description))
      (format stream "~%    )"))))


;;; ----------------------------------------------------------------------
;;; Remnants...

;;; The following doesnt appear to work with merge-pathnames, so
;;; we use string version of the pathnames.... (I.e., we dont get
;;; a list of the required files back somehow...)

(defun BRUTE-FORCE-GRAMMAR-LOAD (root-directory)
  (let ((file-list 
	  (append (stable-directory-wild 
		    (merge-pathnames 
		      (concatenate 'string (namestring root-directory) "*.systems")
		      "*.*.newest"))
		  (stable-directory-wild 
		    (merge-pathnames 
		      (concatenate 'string (namestring root-directory) "*.choosers")
		      "*.*.newest"))
		  (stable-directory-wild 
		    (merge-pathnames 
		      (concatenate 'string (namestring root-directory) "*.inquiries")
		      "*.*.newest"))
		  (stable-directory-wild 
		    (merge-pathnames 
		      (concatenate 'string (namestring root-directory) "*.gram")
		      "*.*.newest")))))
    (dolist (file file-list)
      (kpml-load  file))))

;;; For compatibility with an older version...
(defun LOAD-MONOLINGUAL-LANGUAGE-RESOURCES (lg-root-directory)
  (load-single-language-resources 
   (string curlan)
   (pathname lg-root-directory)))

;;; ----------------------------------------------------------------------
;;; here is an additional function that is used for adding in possibly 
;;; language-specific patches/customizations when the language is reset.
;;; This now includes inquiry implementations, default orderings
;;; and punctuation. All are triggered by a function being found
;;; in the resource directory. 

(defun LOAD-LANGUAGE-SPECIFIC-PATCHES 
  (language &optional (root-directory *root-of-resources*))
  (let* ((lg-name (string language))
	 (lg-root-directory (pathname
			     (concatenate 
				 'string  
			       (namestring root-directory) lg-name 
			       (string *directory-delimiter*)))))

    (cond ((lg-directory-p (pathname lg-root-directory))
	   (let* ((inq-implementations
		   (merge-pathnames (pathname lg-root-directory)  
				    "inquiry-implementations.lisp"))
		  (inq-implementations? (open inq-implementations 
					      :direction :probe))
		  (inquiry-implementations-increment
		   (merge-pathnames (pathname lg-root-directory) 
				    "inquiry-increment.lisp"))
		  (inquiry-implementations-increment?
		   (open inquiry-implementations-increment :direction :probe))
		  (orderings 
		   (merge-pathnames (pathname lg-root-directory) 
				    "ordering-constraints.gram"))
		  (orderings? (open orderings :direction :probe))
		  (punctuation
		   (merge-pathnames (pathname lg-root-directory) 
				    "punctuation.gram"))
		  (punctuation? (open punctuation :direction :probe))
		  (patches 
		   (merge-pathnames (pathname lg-root-directory) 
				    *code-patches-filename*))
		  (patches? (open patches :direction :probe)))
	     (when patches? 
		   (format 
		    t 
		    "~% Language setting: re-customization triggered...")
		   (load patches))
	     (when inq-implementations? 
		   (format 
		    t 
		    "~% Language setting: inquiry implementations changing...")
		   (flush-inquiry-implementation-functions)
		   (load inq-implementations))
	     (when inquiry-implementations-increment?
		   (format t "~% Language setting: incrementing inquiries")
		   (load inquiry-implementations-increment))
	     (when orderings? 
		   (format t "~% Language setting: orderings changing")
		   (kpml-load orderings))
	     (when punctuation?
		   (format t "~% Language setting: punctuation changing")
		   (kpml-load punctuation))
	     ))
	  (t
	   (format 
	    t "~% Language variety: ~A, appears no longer available among 
 the linguistic resources reachable from ~A~% " lg-name root-directory)))))

;;; ----------------------------------------------------------------------
;;; 1.1 Stops where-am-i-id disappearing even if no user-defined choosers
;;;     reference it...

(defun WHERE-AM-I-ID-APPROPRIATE-P (ml region concerned-languages)
  (let* ((curlan (if ml
		     (first concerned-languages)
		   curlan))
	 (appropriate-region 
	  (fetch-system-region (first (who-has-as-input 'start)))))
    (equal region appropriate-region)))

;;; ----------------------------------------------------------------------
;;; Stops annoying breakpoint messages under ACL-PC.

(defun LOAD-NO-WARNINGS (path)
  #+(and aclpc acl3.0)
  (let ((acl::*warn-on-redefinition* nil))
    (load path))
  #-(and aclpc acl3.0)
  (load path))

;;; ----------------------------------------------------------------------
;;; 2.1 utilities for making the somewhat awkward internal treatment
;;;     of versioning transparent...
;;; ----------------------------------------------------------------------

(defun TOGGLE-KPML-VERSIONING ()
  (cond ((member :resource-patches kpml::*loading-saving-profile*)
	 (setf kpml::*loading-saving-profile*
	   (remove :resource-patches kpml::*loading-saving-profile*))
	 (setf *patch-status* nil))
	(t
	 (push :resource-patches kpml::*loading-saving-profile*)
	 (setf *patch-status* T))))

(defun SET-KPML-VERSIONING (value)
  (if value (pushnew :resource-patches kpml::*loading-saving-profile*)
    (setf kpml::*loading-saving-profile*
      (remove :resource-patches kpml::*loading-saving-profile*)))
  (setf *patch-status* value))

(defun PRINT-REGION-DECLARATION (name &optional (stream T))
  (ecase *object-output-mode*
	 (:xml   
	  (format stream "~%<IN-REGION>~S </IN-REGION>" name))
	 (:ascii 
	  (format stream "(in-region :name ~S)~%" name))))

(defun PRINT-LG-DECLARATION (lg-specified &optional (stream T))
  (ecase *object-output-mode*
	 (:xml   
	  (format stream "~%<IN-LANGUAGE>~A</IN-LANGUAGE>" lg-specified))
	 (:ascii 
	  (format stream "(in-language :languages ~S)~3%" lg-specified))))


;;; ----------------------------------------------------------------------
;;; Some stubbs from older versions, no longer maintained or provided...

;;; ----------------------------------------------------------------------
;;; Finally, the compatibility with 0.7- resource structures. These
;;; can be deleted when migration to 0.8 resources is completed.
;;; 4.0, Dec2002: DELETED. 

(defun KPML-0.7-LOAD-GRAMMAR  (root-directory)
  (declare (ignore root-directory))
  (warning "There is no longer any provision for Penman-style or very old KPML-style resource loading. Please refer to the documentation to see how the resources should be organized."))

(defun LOAD-LANGUAGE-RESOURCES (&rest IGNORE)
  (declare (ignore ignore))
  (warning "The load-language-resources function does not exist in anymore; refer to documentation. You probably mean load-linguistic-resources."))


