(in-package "KPML")

;;; File: systems.lisp
;;; 
;;; Contains definition of the linguistic object: system.
;;; Fully multilingual.
;;;
;;; 3.1 March 2000, Bremen: Cleared out CLISP.
;;; Subsequent patches:
;;;
  ;; --------------------------------------------------------------------
  ;; 3.2.2 some of the object-to-list functions were neglecting to do 
  ;;       anything about the comments slot, which means that information
  ;;       here was going missing whenever the systems, etc. were written
  ;;       out! Corrected here and the ragbag of functions cleared up 
  ;;       slightly. The effected functions are: X-to-list-multi-to-mono,
  ;;       X-to-list-multi-to-multi, X-instance-to-list-multi-to-mono,
  ;;       X-instance-to-list-multi-to-multi, with X unfortunately ranging
  ;;       over system, chooser, inquiry, lexeme and example: that is 20
  ;;       functions. Fortunately comments were only overlooked in systems
  ;;       and examples however.
  ;; --------------------------------------------------------------------


(defstruct 
    (SYSTEM (:constructor create-system ) ;avoid conflict with TI make-system
     (:copier copy-grammatical-system))
  (name nil)
  (system-number nil)
  (inputs nil)
  (outputs nil)
  (chooser nil)
  (status nil)
  (selector nil)
  (old-feature nil)
  (row nil)
  (column nil)
  (region nil)
  (metafunction nil)
  (contrastive-sentences nil)
  (comments nil)
  (editor nil)
  (date nil)
  (patch-status nil :type (or symbol list))    ;; added KPML 0.9
  (language-set nil))

;;; ----------------------------------------------------------------------
;;; Management variables...
(defvar *validate-systems* nil)

 ;; Added by 3.2.2...

(defun GATE-INSTANCE-P (instance &optional (lg-variety curlan))
  (and (system-p instance)
       (gethash (first (last (system-name instance))) *gate-table*)
       (member lg-variety 
	       (gethash (first (last (system-name instance))) 
			*gate-table*))))

;;; ----------------------------------------------------------------------
;;; User access...

(defmacro system (&rest arguments)
  `(load-ml-system ',arguments :system))

(defmacro gate (&rest arguments)
  `(load-ml-system ',arguments :gate))

(defun LIST-SYSTEMS (&optional (lg nil))
  (let ((system-names (mapcar #'first systems)))
    (if lg
	(loop for s in system-names
	      when (system-defined-for-lg-p s lg)
	      collect s)
      system-names)))

(defun SYSTEM-DEFINED-FOR-LG-P (name lg)
  (let ((system-instance (gethash name system-table)))
    (and 
     system-instance
     (member lg (system-language-set system-instance))
     (eq name (strip-lx (parse-clause (system-name system-instance) lg)))))) 

;
; legal-ls: find out if an LS is within a language set
;
(defmacro legal-ls (ls ls-set)
  `(if ,ls-set (member ,ls ,ls-set) t))

;;; ----------------------------------------------------------------------
;;; Management functions...
;;; (From Licheng's ml-penman-output-feat-class.lisp)
;/*------------------------------------------------------------------
;          Implementation of output-feature object class
;/*-----------------------------------------------------------------
;
;struct output-feature::features {
;
;	struct  feature-db {
;		string		feature; /*keyword*/
;		list		eligible-languages;     /* new */
;		} all-output-features[number-of-all-output-features];
;
;	struct  system-output-feat {
;		string		system-name; /* keyword */
;		list		eligible-languages;   /* new */
;		struct {	
;				symbol	ls;
;				list	OutputFeatures;
;		        } 	OutputFeatureList [number-of-languages]; 
;				/* sorted according to language, e.g. (:L1 f1 f2)(:L2 f1 f3) */
;		} system-output-features[number-of-systems];
;
;	/*-- functions on all-output-features --*/
;	struct feature-db
;			register-an-output-feature(feature, list-of-language-specifiers);
;	list		find-grammatical-feature-like(),
;			list-grammatical-features(),
;			unreachable-inputs-test(),
;			feature-survey(),
;			erase-grammar();
;			/* these are the original functions that use all-output-features, and need to 
;                          be modified */
;
;	/*-- functions on system-output-features --*/
;	struct system-output-feat 
;			replace-output-features(system-name, system-output-feature-list, &option ls);
;	outputfeatures	fetch-output-features(system-name, &option ls);
;	}
;
;/*----------------------------------------------------------------------------------------------------------------------*/

;-------------------------------------------------------------------------------------------------------------------------
; syntax: register-an-output-feature (feature-name, language-specifiers-relevant-for-the-feature)
; return: an entry in all-output-features DB may be inserted as (feature, list-of-ls);
; assume: existence of DB
; target: as implied
; global: all-output-features
; symbol: DB = all-output-features
; pseudo: find in DB for feature-name. If exists, then we get info, and union list-of-ls with info; else create an entry
;         and put (feature, list-of-ls) pair into it; This strategy already handled in Lisp hash-table function.
;------------------------------------------------------------------------------------------------------------------------

(defun register-an-output-feature (feature LS-lst)
  (setf (gethash feature all-output-features) (union (gethash feature all-output-features) LS-lst)))

;-------------------------------------------------------------------------------------------------------------------------
; syntax: fetch-output-features (sys-name, &optional ls)
; return: list of features that a system sends out in a given ls;
; assume: 
; target: as implied;
; global: system-output-features
; symbol:
; pseudo: search hash "system-output-features" for sys-name, and stick outFtr to the entry.
;         if OutFtr does not exist, return nil;
;         if LS not specified, return the complete field;
;         else find OutputFeatureList for the proper language specifier and return the outputfeatures;
;------------------------------------------------------------------------------------------------------------------------

(defun fetch-output-features (sys-name &optional ls)
  (let ((OutFtr (gethash sys-name system-output-features)) pair)

    (unless OutFtr (return-from fetch-output-features nil))
    (unless ls (setq ls CurLan))
    (unless ls (return-from fetch-output-features OutFtr))
    (setq pair (assoc ls OutFtr))
    (if pair (cdr pair) nil)
))

;-------------------------------------------------------------------------------------------------------------------------
; syntax: replace-output-features (sys-name, output-features, &optional ls)
; return: list of features that a system sends out in a given ls; an entry in system-output-features might be inserted;
; assume: existence of system-output-features DB, CurLan;
; target: replace or add-in the output features of a system under a certain language situation ls.
; global: system-output-features
; symbol: OutFtr = pointer to the storage of output features of sys-name;
; pseudo: This is a Hack! There is some trick here for the simplicity of code.
;
;         search hash "system-output-features" for sys-name, and stick outFtr to the entry.
;         (we assume the entry always exists. If it does not exist, the variable pair will be nil)
;         if LS is specified, and LS is associated with an outputfeature, replace the old outputfeature
;            with the output-features; if LS is not associated with any feature, make an assoc-list &
;            append this assoc-list to the existing outputfeaturelist;
;         if LS is not specified, then LS means all possible languages, and each language will have 
;            output-features for the current system;
;------------------------------------------------------------------------------------------------------------------------

(defun replace-output-features (sys-name output-features &optional ls)
  (let ((OutFtr (gethash sys-name system-output-features)) pair)

    (unless ls (setq ls CurLan))
    (if ls 
	(block nil
	  (setf pair (assoc ls OutFtr))
	  (if pair (rplacd pair output-features) 
	      (setq OutFtr (append OutFtr (list (cons ls output-features))))
	      ))
	(setq OutFtr (loop for eachLan 
			   in ALL_LANGUAGES collect (cons eachLan output-features)) )
	)
    (setf (gethash sys-name system-output-features) OutFtr)
))


(defsetf fetch-output-features (system-name &optional LS) (new-features) 
  `(replace-output-features ,system-name ,new-features ,LS) )

;;; ----------------------------------------------------------------------
;-------------------------------------------------------------------------------------------------------------------------
; syntax: fetch-system-selector-associations (single-sys-name, optional-language-specifier)
; return: selector name;
; assume: CurLan. Function properly in ML-penman only.
; target: get a selector name;
; global: Curlan, system-selector-associations DB
; symbol: SLCTR = selector record for sys-name; pair = an element in slctr;
; pseudo: search DB for sys-name, if not exist, return nil, else we obtain SLCTR;
;         if ls is nil, ls = CurLan; if CurLan = nil, return all slctr;
;         find ls is assoc with any (ls selector) pair in SLCTR. If found return selector, else return nil;
;------------------------------------------------------------------------------------------------------------------------

(defun fetch-system-selector-associations (system-name &optional ls)
  (let ((slctr (gethash system-name system-selector-associations)) pair)

    (unless slctr (return-from fetch-system-selector-associations nil))
    (unless ls (setq ls CurLan))
    (unless ls (return-from fetch-system-selector-associations slctr))
    (setq pair (assoc ls slctr))
    (if pair (second pair) nil)
))

;-------------------------------------------------------------------------------------------------------------------------
; syntax: same as declared
; return: new value; an new entry in system-selector-association DB might be added;
; assume: same as above;
; target: depending on the original data in the DB, the function might add in or replace part of entry in the DB;
; global: same as above
; symbol: same as above;
; pseudo: search DB for sys-name;
;         if (not exist) create a new instance;
;         in any case,  we obtain a slctr;
;         if ls = nil then  ls = CurLan;
;         if ls = nil, then for eachlanguage in ALL_LANGUAGES put (eachlanguage, new-value) pair into
;                           slctr; 
;                      else find (ls selector) pair in slctr, if found, selector := new-value else 
;                           add in (ls new-value) to slctr
;         put slctr into hashtable;
;         (notice, there is a trick here. we first prepare slctr regardless whether it exists or not;
;          The final setf (gethash .. DB) statement can function both as replacing and inserting.)
;------------------------------------------------------------------------------------------------------------------------

(defun replace-system-selector-associations (sys-name new-slctr &optional ls)
  (let ((slctr (gethash sys-name system-selector-associations)) pair)

    (unless (listp new-slctr) (setq new-slctr (list new-slctr)))
    (unless ls (setq ls CurLan))
    (if ls 
	(block nil
	  (setf pair (assoc ls slctr))
	  (if pair 
              (rplacd pair new-slctr) 
	      (setq slctr (append slctr (list (cons ls new-slctr))))
	  ))
	(setq slctr (loop for eachLan in ALL_LANGUAGES collect (cons eachLan new-slctr)) )
	)
    (setf (gethash sys-name system-selector-associations) slctr)
))

(defsetf fetch-system-selector-associations 
    (system-name &optional LS) (new-selector) 
  `(replace-system-selector-associations ,system-name ,new-selector ,LS) )

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

;;; Following from ml-penman-system-class. The assumption that a system can
;;; only belong to a single metafunction was hardwired into the following
;;; function. This is now changed...

(defun FETCH-SYSTEM-METAFUNCTION (system-name &optional (ls curlan))
  (let ((instance (gethash system-name system-table)))
    (if instance (strip-LX (parse-clause (system-metafunction instance) ls))
      nil)))


;-----------------------------------------------------------------------------------------------------
; syntax: fetch-system-FIELD (system-name &optional language-specifier)
; target: given a system name and language specifier, it finds out the content of a certain field.
; assume: curLan is instantiated;
; pseudo: This is a generic function; depending on fields, we have different functions, but they look
;         generally like below:
;         if system does not exist, return nil, otherwise get INSTANCE;
;         if optional ls is specified, ls overrides CurLan;
;         if ls is not covered in the INSTANCE, return nil;
;         calling get-ls-atom function to fetch the field of a given language and return it;
;
;         The general algorithm for replacing field in system-table remain unchanged for the time 
;         being. That means the new
;         value will simply replace all of the original contents in that field regardless of the 
;         language specifier and the systems created in these functions are language-neutral. The 
;         only change is that replace-system-FIELD functions no longer create an system entry; they 
;         simply return if they cannot find system-name exists in system-table. That means One has 
;         to explicitely insert an empty new entry, before he can use replace-functions to fill in 
;         new data.
;
;         In order to be compatible with original code, we have to redefine most of those 
;         (defsetf fetch-X replace-X). The problem here is that the current fetch-system-FIELD and 
;         Replace-system-FIELD both take an optional language specifier. So we have to expand the 
;         calling of "setf fetch-system-FIELD" into macros using CommonLisp facility;
;
;            It is quite risky to use the current replace-system-FIELD functions. However in the 
;         future, we shall do like this: extract the data prefixed by LS from the original content, 
;         and append them to the left-over data.
;;----------------------------------------------------------------------------------------------------

(defun fetch-system-chooser (system-name &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from fetch-system-chooser nil))
    (unless ls (setq ls CurLan))
    ;;    (if (not (legal-ls ls (system-language-set instance))) (return-from fetch-system-chooser nil))
    ;;    (second (assoc ls (get-ls-atom (system-chooser instance))))
    (strip-LX (parse-clause (system-chooser instance) ls))
    ;; notice the parse-clause function is used here instead of 
    ;; get-ls-atom because the former is more efficient.
    ;; Strip-LX is used here to convert a single element list to a value.
))

(defun replace-system-chooser (system-name new-value &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from replace-system-chooser nil))
    (if ls 
	(setf (system-chooser instance) 
	  (if (assoc ls (system-chooser instance)) 
	      (rplacd (assoc ls (system-chooser instance)) new-value)
	    (setf (system-chooser instance) 
	      (append (system-chooser instance) (list (cons ls new-value))))))
      (setf (system-chooser instance) new-value))))

(defsetf fetch-system-chooser (system-name &optional LS) (new-chooser) 
  `(replace-system-chooser ,system-name ,new-chooser ,LS) )

;
; fetch-system-inputs: parse-clause is sufficient to obtain right input clause from a system,
;                      thanks to the uniformity of LX expression.
; BUT: still need to do a strip-LX for top level conditionalization!  IPSI:John:Oct91

(defun fetch-system-inputs (system-name &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from fetch-system-inputs nil))
    (unless ls (setq ls CurLan))
    (strip-LX (parse-clause (system-inputs instance) ls))))
    
(defun replace-system-inputs (system-name new-value &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from replace-system-inputs nil))
    (if ls 
	(setf (system-inputs instance) 
	  (if (assoc ls (system-inputs instance)) 
	      (rplacd (assoc ls (system-inputs instance)) new-value)
	    (setf (system-inputs instance) 
	      (append (system-inputs instance) (list (cons ls new-value))))))
      (setf (system-inputs instance) new-value))
    (setf (gethash system-name system-table) instance)))

(defsetf fetch-system-inputs (system-name &optional LS) (new-inputs)
  `(replace-system-inputs ,system-name ,new-inputs ,LS) )
;
; old-feature is an a-list. (:l feature) Replace-function will not create a new system here
; 4.1 update of old-feature, it is still an a-list, but the second element
;     is now itself an a-list of the form (constituent . feature). 
;     The following code is more or less unchanged, since it does not
;     need to know what 'feature' actually is.
;     (John, Bremen, July06)
;
(defun fetch-system-old-feature (system-name &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from fetch-system-old-feature nil))
    (unless ls (setq ls CurLan))

;;;> IPSI: the following is wrong.
;;;    (second (assoc ls (system-old-feature instance)))
;;; probably was meant to be the following because of the a-list:
    (cdr (assoc ls (system-old-feature instance)))
))

(defun replace-system-old-feature (system-name new-value &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from replace-system-old-feature nil))
    (unless ls (setq ls CurLan))
    (if (assoc ls (system-old-feature instance)) 
      (rplacd (assoc ls (system-old-feature instance)) new-value)
      (setf (system-old-feature instance) (append (system-old-feature instance) (list (cons ls new-value)))))
 ))

(defsetf fetch-system-old-feature replace-system-old-feature)

;
; fetch-system-outputs: system output is a clause that might be complicated by nesting of language
;                       specifiers. e.g. a legal output clause might look like this:
;
; (0.5 CLAUSES
;             :not :chinese                ((insert mood)
;                                           (expand mood finite)
;                                           (insert finite)
;                                           (conflate finite process)
;                                           (expand mood subject)) 
;             :english                     (inflectify finite presentform)
;                                          (insert process)
;                                          (classify process verb)
;                                         )
; After parse-clause in German environment, the clause will look like this:
; (0.5 clauses ((insert mood)(expand mood finite)(insert finite)(conflate finite process)
;               (expand mood subject)) (insert process) (classify process verb))
;
; The original Penman traversing algorithm won't recognize this nested realization statements.
; Without changing the original code, what we shall do is to unnest the nested realization stmts.
; However, it's unwise to build unnesting mechanism into parse-clause because sometimes nesting
; is just desired. So we write a short function Unnest-LX here to spread nested lists into flat one.

(defun fetch-system-outputs (system-name &optional ls)
  (let ((instance (gethash system-name system-table)) goodoutputs)

    (if (not instance) (return-from fetch-system-outputs nil))
    (if (not ls) (setq ls CurLan))
    (setq goodoutputs 
          (loop for EachSysOut in (parse-clause (system-outputs instance) ls)
		collect (append (list (first EachSysOut)       ; probability
				      (second EachSysOut))     ; output feature
				(Unnest-LX (cddr EachSysOut)) 
				))      ; spread nested realization statements
					; created through LS nesting.
          )

    (if (atom (caar goodoutputs))
        (return-from fetch-system-outputs goodoutputs)
        (return-from fetch-system-outputs (Strip-LX goodoutputs) )        
        )                                  ; if outputs after de-nesting is a normal output clause
                                           ;    (evidenced by (caar output) = number)
                                           ; then original Penman can use it, we simply return it;
                                           ; else the output clause contains over-nesting created
                                           ;      LS scoping in LX formalism, we shall strip the
                                           ;      exterior nest;                                           
))
  
(defun Unnest-LX (RealStmts)
  (let ((x nil))

    (loop for EachStmt in RealStmts do
	  (if (listp (car EachStmt))
	      (setq x (append x (unnest-lx EachStmt)))
	    (setq x (append x (list EachStmt)))
	    )
    )
    (return-from Unnest-LX x)
))

(defun replace-system-outputs (system-name new-value &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from replace-system-outputs nil))
    (if ls 
	(setf (system-outputs instance) 
	  (if (assoc ls (system-outputs instance)) 
	      (rplacd (assoc ls (system-outputs instance)) new-value)
	    (setf (system-outputs instance) 
	      (append (system-outputs instance) (list (cons ls new-value))))))
      (setf (system-outputs instance) new-value))))

(defsetf fetch-system-outputs replace-system-outputs)

(defun replace-system-metafunction (system-name new-value &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from replace-system-metafunction nil))
    (if ls 
	(setf (system-metafunction instance) 
	  (if (assoc ls (system-metafunction instance)) 
	      (rplacd (assoc ls (system-metafunction instance)) new-value)
	    (setf (system-metafunction instance) 
	      (append (system-metafunction instance) 
		      (list (cons ls new-value))))))
      (setf (system-metafunction instance) new-value))))

(defsetf fetch-system-metafunction replace-system-metafunction)

(defun fetch-input-features (system-name &optional (ls curlan))
  (compute-system-input-features (fetch-system-inputs system-name ls)))


; similar to fetch-system-chooser. Region is currently not important, 
; however in future it may be very significant. (LZ, 1991).
; IPSI: changed after the model of fetch-system-chooser, to return
;       a single element not a list, to remain consistent with
;       other region handling functions in monolingual Penman and
;       new developments: John: 11.11.91.
; 4.0   does not, unfortunately, bother to check whether a 
;       system was even defined for the current language...
;
(defun fetch-system-region (system-name &optional ls)
  (let ((instance (gethash system-name system-table)))
    (if (not instance) (return-from fetch-system-region nil))
    (if (not ls) (setq ls CurLan))
    (strip-LX (parse-clause (system-region instance) ls))))

;;; was: 
;;; (cdr (assoc ls (get-ls-atom (system-region instance))))

(defun replace-system-region (system-name new-value &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from replace-system-region nil))
    (if ls 
	(setf (system-region instance) 
	  (if (assoc ls (system-region instance)) 
	      (rplacd (assoc ls (system-region instance)) new-value)
	    (setf (system-region instance) 
	      (append (system-region instance) (list (cons ls new-value))))))
      (setf (system-region instance) new-value))))

(defsetf fetch-system-region replace-system-region)

;
; system-number, row, column are similar to metafunction type. Only one instance for one system
;
(defun fetch-system-system-number (system-name)
(let ((instance (gethash system-name system-table)))
    (if instance (system-system-number instance) nil)))

(defun replace-system-system-number (system-name new-value &optional ls)
  (declare (ignore ls))
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from replace-system-system-number nil))
    (setf (system-system-number instance) new-value)
    ))

(defsetf fetch-system-system-number replace-system-system-number)

;;
(defun fetch-system-row (system-name)
  (let ((instance (gethash system-name system-table)))
    (if instance (system-row instance) nil)))

(defun replace-system-row (system-name new-value &optional ls)
  (declare (ignore ls))
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from replace-system-row nil))
    (setf (system-row instance) new-value)
    ))

(defsetf fetch-system-row replace-system-row)

;
(defun fetch-system-column (system-name)
(let ((instance (gethash system-name system-table)))
    (if instance (system-column instance) nil)))

(defun replace-system-column (system-name new-value &optional ls)
  (declare (ignore ls))
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from replace-system-column nil))
    (setf (system-column instance) new-value)
    ))

(defsetf fetch-system-column replace-system-column)

;;; system comments, contrastive-sentences, editor and date are 
;;; sensitive to language specifier and 
;;; similar to old-feature type. Their data structures are a-lists.

(defun fetch-system-comments (system-name &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from fetch-system-comments nil))
    (unless ls (setq ls CurLan))

;;;> IPSI; note the (system-comments instance) will most
;;;        likely return a string, not a list, or a list of one string, so this
;;;        case needs to be handled
;    (second (assoc ls (system-comments instance)))

    (cond ((listp (system-comments instance))
	   (if (eq (length (system-comments instance)) 1)
	       (system-comments instance)
	     (cdr (assoc ls (system-comments instance)))))
	  (t
	   (system-comments instance)))))


(defun replace-system-comments (system-name new-value &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from replace-system-comments nil))
    (unless ls (setq ls CurLan))
    (if (assoc ls (system-comments instance)) 
        (rplacd (assoc ls (system-comments instance)) new-value)
        (setf (system-comments instance) 
              (append (system-comments instance) (list (cons ls new-value)))))
 ))

(defsetf fetch-system-comments replace-system-comments)


(defun fetch-system-contrastive-sentences (system-name &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from fetch-system-contrastive-sentences nil))
    (unless ls (setq ls CurLan))
    (cdr (assoc ls (system-contrastive-sentences instance)))
))

;;; Note accompanying 0.7.17
;;; The following kind of function assume that the internal form
;;; of the data structure is already multilingual, but sometimes
;;; they are not (e.g., when a single string is given as the
;;; editor). This (and similar) functions should not break when
;;; this is the case: hence the change. A further option would
;;; be to change the load-system function so that the appropriate
;;; internal form is always created. This is probably the 
;;; preferred change but has yet not been done.

(defun FETCH-SYSTEM-EDITOR (system-name &optional ls)
;;; 0.7.17 fixed so that single strings do not cause it to bomb...
  (let* ((instance (gethash system-name system-table))
	 (value (if instance (system-editor instance) nil)))
    (unless instance (return-from fetch-system-editor nil))
    (unless ls (setq ls CurLan))
    (cond ((stringp value) value)
	  ((listp value)
	   (cdr (assoc ls (system-editor instance))))
	  (t
	   nil)))) 

(defun replace-system-editor (system-name new-value &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from replace-system-editor nil))
    (unless ls (setq ls CurLan))
    (if (assoc ls (system-editor instance)) 
        (rplacd (assoc ls (system-editor instance)) new-value)
        (setf (system-editor instance) 
              (append (system-editor instance) (list (cons ls new-value)))))
 ))

(defsetf fetch-system-editor replace-system-editor )  

(defun fetch-system-date (system-name &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from fetch-system-date nil))
    (unless ls (setq ls CurLan))
    (cdr (assoc ls (system-date instance)))
)) 

(defun replace-system-date (system-name new-value &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from replace-system-date nil))
    (unless ls (setq ls CurLan))
    (if (assoc ls (system-date instance)) 
        (rplacd (assoc ls (system-date instance)) new-value)
        (setf (system-date instance) 
              (append (system-date instance) (list (cons ls new-value)))))
 ))

(defsetf fetch-system-date replace-system-date )

;;; Following functions were from data-access-functions.lisp
;;; originally... They now take an additional argument
;;; which determines the language for which the disablement 
;;; is concerned. The form of the entries on *disabled-systems* is now
;;; that each is a list consisting of the system name and the language
;;; for which it is disabled. There may be multiple entries for a
;;; given system if the system is disabled for multiple languages. It
;;; is not envisaged that the number of disabled systems should ever
;;; become particularly large, so no attempt for great efficiency has
;;; been made.

(defun FETCH-DISABLED-SYSTEM (system-name &optional (lg curlan))
  (if (member (list system-name lg) *disabled-systems* :test #'equal)
      system-name
      nil))

(defun REPLACE-DISABLED-SYSTEM (system-name lg new-value)
  (if new-value
      (pushnew (list system-name lg) *disabled-systems*
	       :test #'equal)
    (setq *disabled-systems* 
	  (delete (list system-name lg) *disabled-systems* :test #'equal))))

(defsetf fetch-disabled-system replace-disabled-system)


;;; ----------------------------------------------------------------------
;;; KPML 0.9 addition... (modelled on region slot)

(defun FETCH-SYSTEM-PATCH-STATUS (system-name &optional ls)
  (let ((instance (gethash system-name system-table)))
    (if (not instance) (return-from FETCH-SYSTEM-PATCH-STATUS nil))
    (if (not ls) (setq ls CurLan))
    (strip-LX (parse-clause (system-patch-status instance) ls))))


;;; 1.1. Following did not do anything with the language. Changed
;;;      to work normally multilingually as must surely have been
;;;      intended.
(defun REPLACE-SYSTEM-PATCH-STATUS (system-name new-value &optional ls)
  (let ((instance (gethash system-name system-table)))
    (unless instance (return-from REPLACE-SYSTEM-PATCH-STATUS nil))
    (if (not ls) (setf ls curlan))
    (setf (system-patch-status instance) 
      (if (assoc ls (system-patch-status instance)) 
	  (rplacd (assoc ls (system-patch-status instance)) new-value)
        (setf (system-patch-status instance) 
	  (append (system-patch-status instance) 
		  (list (cons ls new-value))))))))


;;; ----------------------------------------------------------------------
;;; Loading...

; *** Additions (John:IPSI:Feb94) for including default 
;     in-region information
;     and for automatic merging rather than overwriting.
; *** Correction (John:Hiddensee:Aug94): merge-new-and-old-system 
;     previously
;     did not overwrite if merging was disabled!
; *** Correction (John:IPSI:Dec94): precompiles were being
;     called on the new instance only and not on merged forms.
;
(defun LOAD-ML-SYSTEM (body status)
  (let ((seed-instance (apply #'create-system body)))

; 0.7.29 fix combination of defaults and explicit conditionalizations.
    (when (symbolp (system-name seed-instance))
	  (setf (system-name seed-instance)
		(append 
		 (cond 
		  ((and *in-ml-region* *current-default-languages*)
		   (check-language-availability *current-default-languages*)
		   *current-default-languages*)
		  (t  all_languages))
		 (cons (system-name seed-instance) nil))))

; following the above, the name slot of the seed instance is guaranteed
; to contain the definitional languages for the new instance.
    
; 0.9 add in correct patch status... 
    (setf (system-patch-status seed-instance)
      (append (extract-lg-specifiers (system-name seed-instance))
	      (cons *patch-status*  nil)))

    ;; 1.0
    (when *patch-status* (setf *patches-exist* T))

    (let ((names (get-atom-ls (system-name seed-instance)))
	  instance name-lg-spec)

;** Check for  existing systems of same name, if merging is allowed 
;   then attempt this... If no merging allowed, 
;   then merge-new-and-old-system
;   has to delete any old systems of the same name regardless.
;** Note that the third parameter of merge-new-and-old-system has to
;   specify the language(s) of the new instance; this may be:
;    i. all languages
;    ii. the current defaults given by in-region
;    iii. actual conditionalizations present in the name
;   all cases are already provided by the call to get-atom-ls and
;   the when-clause above. (cdr name) now always contains the
;   definitional languages for the new system.

      (loop for name in names do
	   (setf instance 
		 (merge-new-and-old-system name seed-instance (cdr name)))

;-- check data ---
;   (if (sys-def-invalid instance) (return-from 'load-ml-system nil))

; register system in system-table, using the principle in the
; documentation. Notice the trick of (setf (gethash X system-table)
; instance) below. It creates two indexes pointing to a single storage
; of system information. LS-set field accumulates valid language
; specifiers. This trick is not harmful, since each subsequent access
; to system-table will call Parse-Clause function, which will always
; get correct message from the integrated LX expression.  

	   (setf (gethash (car name) system-table) instance)
	   (setf (system-old-feature instance) nil)
	   (setf (system-language-set instance) 
		 (union (cdr name) (system-language-set instance)))
		 
; following makes sure that the list of systems has the correctly
; specified language applicability conditions (i.e., including
; that induced by merges)
	   (setf name-lg-spec (cons (car name) 
				    (system-language-set instance)))
	   (push  name-lg-spec systems)

;-- Register gate ---
;   0.9 added in line with John Wilkinson's speedpatches...
	   (when (eq status :gate) (push (car name) list-of-gates))
	   (update-gate-table-language-entry 
	    (or (eq status :gate)
		(eq status :intergate))
	    (car name) (system-language-set instance))
;--(External resources; John:Budapest:Sep94): Note, not properly multilingual...
	   (when (eq status :external)
		 (pushnew (car name) *list-of-external-systems*)
		 (dolist (f (system-outputs instance))
			 (pushnew (second f) *externally-constrained-features*)))
	   (when (eq status :intergate)
	     (push (car name) list-of-gates)
	     (pushnew (car name) *list-of-intergates*)
	     (dolist (f (cdr (system-inputs instance)))
	       (unless (who-has-as-output f)
		 (pushnew f *input-features-of-intergates*)))
	     )

;  do series of precompilation for each system  name while the grammar
;  is being loaded
	   (precompile-inputs name-lg-spec (system-inputs instance))
	   (precompile-outputs name-lg-spec (system-outputs instance)
			       (cdr name))
	   (precompile-selectors name-lg-spec (system-selector instance)))
      (setf *network-updated?* all_languages)
      )))


;;; 0.9 added for fast multilingual gate checking...
;;;     System maintains *gate-table* to be a hash table which maps
;;;     gate names and only gate names to the languages for which they
;;;     they are actually gates.

(defun UPDATE-GATE-TABLE-LANGUAGE-ENTRY (gate? name ls-set)
  (let ((table-entry (gethash name *gate-table*)))
    (if gate?
	(cond (table-entry 
	       (loop for l in ls-set do (pushnew l table-entry))
	       (setf (gethash name *gate-table*) table-entry))
	      (T
	       (setf (gethash name *gate-table*) ls-set)))
      (when table-entry
	(setf (gethash name *gate-table*)
	  (set-difference table-entry ls-set))))))


;;; Following function used in  load-ml-system seemed to have given up
;;; taking any   action when features that are   used in other systems
;;; also appear in  new systems.  Old   action was to  disable the old
;;; system, which does still make sense *as long as it is for the same
;;; language*. Now a call to a new function check-feature-use is added
;;; to   take  care of  this contingency.   Still   have to be careful
;;; because  of  the   possibility   of knots   in    the multilingual
;;; expression...
;;; (John:Hiddensee:Aug94; function originally from
;;; ml-penman-system-class.lisp)
;;;
;;; Indirectly sets up chosen-by slot (via check-feature-use) of
;;; the feature-information structure, and entries (via
;;; register-an-output-feature) of the all-output-features
;;; structure.

;;; New Version: John:IPSI:Dec94.
;;; The parameters to the following function are
;;; (i) a ml-system name (language varieties as suffixes)
;;; (ii) the output slot of the system internal structure.
;;; Given that all information about this system is now
;;; known (i.e., which languages it is relevant for), we
;;; can simplify the code somewhat wrt previous versions:
;;; we do not need to use get-atom-ls, etc. but can go
;;; directly to parse-clause and extract the output
;;; features.

(defun PRECOMPILE-OUTPUTS (EachSysName outputs definitional-lgs)
;;; KPML 0.7.30 note that only definitional languages can call for
;;;            systems to be disabled.
  (let ((relevantLS (cdr EachSysName))
	(sysname (car EachSysName)))
    (loop for lg in (if relevantLS relevantLS
		      all_languages)
	  do
	  (let ((output-features nil))
	    (mapcar 
	     #'(lambda (output-feature-spec)
		 (let ((feature (second output-feature-spec)))
; register a feature in all-output-features DB 
; and check its uniqueness...
		   (register-an-output-feature feature (list lg))
		   (check-feature-use feature sysname lg definitional-lgs)
		   (push feature output-features)))
	     (parse-clause outputs lg))
	    (setf (fetch-output-features sysname lg) 
		  output-features)))))

;;; New  function, for checking   the  use of features during  grammar
;;; loading.    Draws on record-feature  defined in penman/system.lisp
;;; (which is, incidentally, not used anymore). Is responsible for
;;; setting up the chosen-by slot of the feature-information
;;; structure.

;;; KPML 0.7.30: need to make sure that if a system of a given name
;;;             for some language(s) is loaded and a previously loaded
;;;             language had already disabled a system of the same
;;;             name, then that view on the system remains disabled
;;;             in the merged object. That is, the status of some
;;;             system is only changed when that system is explicitly
;;;             being defined, not when an object is (re-)created 
;;;             implicitly as part of the merging operation.

(defun CHECK-FEATURE-USE (feature system lg definitional-lgs)
  (cond
    ((And (member lg definitional-lgs)
	  (fetch-exact-feature-def-field 'Chosen-By feature lg)
	  (Not (member system (fetch-exact-feature-def-field 'Chosen-By feature lg))))
     (Warning "For language " lg ", the feature  " feature " was defined for system  " 
	      (fetch-exact-feature-def-field 'Chosen-By Feature lg)
	      ", but  now system " system " is also claiming it.")
     (let ((out-string 
	    (format nil "Disabling: ~a" 
		    (fetch-exact-feature-def-field 'Chosen-By Feature lg))))
       (printwindow :display-pane (cons " " (indent-and-fill out-string))))
     (loop for S in (fetch-exact-feature-def-field 'Chosen-By Feature lg)
	   when (not (equal S system))
	   do (disable-system S lg) )))

  (setf (fetch-exact-feature-def-field 'chosen-by feature lg)
	(remove-duplicates
	 (cons system (fetch-exact-feature-def-field 'chosen-by feature lg)))))

;;; Following function sets up the waiting slot of the 
;;; feature-information structure...

;;; New version: John:IPSI:Dec94.
;;; Relies on all information being now present, as for
;;; PRECOMPILE-OUTPUTS. 

(defun PRECOMPILE-INPUTS (EachSysName inputs)
  (let ((relevantLS (cdr EachSysName))
	(sysname (car EachSysName)))
    (loop for lg in (if relevantLS relevantLS
		      all_languages)
	  do
	  (loop for feature in
		(mapcar #'first (get-atom-ls (parse-clause inputs lg)))
		do
		(setf (fetch-exact-feature-def-field 
		       'waiting feature lg)
			 (remove-duplicates ;; <======= John:IPSI:Dec91
			   (cons sysname (fetch-exact-feature-def-field 
					  'waiting feature lg))))))))

(defun PRECOMPILE-SELECTORS (EachSysName selectors)
  (let ((SlctrLst (get-ls-atom selectors)) sys ls)
    (if (cdr EachSysName) (setq ls (cdr EachSysName)) 
      (setq ls ALL_LANGUAGES))
    (setq sys (car EachSysName))
    (loop for  EachSlctr in SlctrLst 
	do
	  (if (member (car EachSlctr) LS) 
	      (setf (fetch-system-selector-associations 
		     sys (car EachSlctr)) 
		(cdr EachSlctr)))
	  )
    SlctrLst))

;;; ----------------------------------------------------------------------
;;; Removing...

(defun DELETE-SYSTEM-FOR-LG (Sys Language)
  (cond
    ((system-defined-for-lg-p sys language)
                                   ;; WARNING: classic penman code:
     (SETQ Paths-Valid NIL)        ;; great, terrific, wonderful: what this does and will do
                                   ;; to us unexpectedly in the future is anyone's guess! :-()
                          ;; From a comment in enable-system, it seems that this
                          ;; variable is actually an indication of whether the
                          ;; augmented preselection paths (critical for traversing
                          ;; the grammar) are up to date or not. Why we should
                          ;; be allowed to traverse the grammar when this variable
                          ;; is set to NIL I can't think.. (John: Aug 28, 1994,
                          ;; Hiddensee)

     (setf systems 
	   (dremove nil
		    (mapcar #'(lambda (s)
				(cond ((eq (first s) sys)
				       (cond ((member language (cdr s))
					      (setf (cdr s) (dremove language (cdr s)))
					      (if (null (cdr s)) nil s))
					     (t s)))
				      (t s)))
			    systems)))

     (dolist (Feat (fetch-input-features Sys language))
	     (setf (fetch-exact-feature-def-field 'Waiting Feat language)
		   (remove Sys (fetch-exact-feature-def-field 'Waiting Feat language))))
     (dolist (Feat (fetch-output-features Sys language))
	     (setf (fetch-exact-feature-def-field 'Preselection-Features Feat language) NIL)
	     (setf (fetch-exact-feature-def-field 'Chosen-By Feat language)
		   (remove Sys (fetch-exact-feature-def-field 'Chosen-By Feat language)))
	     (setf (fetch-exact-feature-def-field 'Voidness Feat language) NIL))
     (dolist (x (fetch-output-features Sys language))
	     (remhash x All-Output-Features ))

     (unless (member sys
		     (mapcar #'first systems))
	     (remhash sys system-table))
     Sys)))

;;; Delete-system  deletes    for          all
;;; languages... Note this is a  much stronger delete-system than that
;;; previously defined, as it really does  try to remove all traces of
;;; the system. There is now also a slightly  weaker version that does
;;; the same   but only  for  a  selected language. This  is  given in
;;; ml-new-utilities.lisp.

(defun DELETE-SYSTEM (sys)
  (cond
    ((gethash Sys system-table)  
     (setf Paths-Valid NIL)  ;; preselection paths no longer uptodate...

;; remove the name from the list of systems (for all languages)...
     (setf systems (loop for entry in systems  
			unless (eq (first entry) sys)
			collect entry))

;; kill references to the features of the system for each language
;; for which the system is defined...
     (loop for language in (system-language-set (gethash sys system-table))
	  do
	  (dolist (Feat (fetch-input-features Sys language))
		  (setf (fetch-exact-feature-def-field 
			 'Waiting Feat language)
			(remove Sys (fetch-exact-feature-def-field 
				     'Waiting Feat language))))
	  (dolist (Feat (fetch-output-features Sys language))
		  (setf (fetch-exact-feature-def-field 
			 'Preselection-Features Feat language) NIL)
		  (setf (fetch-exact-feature-def-field 
			 'Chosen-By Feat language)
			(remove Sys (fetch-exact-feature-def-field 
				     'Chosen-By Feat language)))
		  (setf (fetch-exact-feature-def-field 
			 'Voidness Feat language) NIL))
	  (dolist (x (fetch-output-features Sys language))
		  (remhash x All-Output-Features )))

     (remhash sys system-table)
     Sys)))

(defun ERASE-SYSTEMS ()
  (setq systems nil)
  (setq paths-valid nil)
  (clrhash all-output-features)
  (clrhash system-output-features) ;; somehow forgotten; added John:IPSI:March 94
  (clrhash feature-information)
  (clrhash system-enter-first-associations)
  (clrhash system-selector-associations)
  (clrhash hash-table-of-all-functions )
  (clrhash show-pass-hash-table )
  (setq list-of-all-grammatical-functions nil)
  (clrhash system-table)
  (setq *disabled-systems* nil)
  (setq lexical-class-defs nil)  ;; don't know what this is... John:March 95.
  )

;;; ----------------------------------------------------------------------
;;; Disabling...

;;; ml-system-disabling.lisp
;;; John: Sep94: Hiddensee.
;;;
;;; Updates and extends   functionality  for  `disabling'  grammatical
;;; systems so as to  be fully compatible with multilingual resources.
;;; In general,    disabling  is now   always relative  to  particular
;;; languages. All   necessary  code changes    for this are   brought
;;; together here.   Disabling most  commonly occurs automatically due
;;; to changes in resource definitions. Features can not, for example,
;;; be own by  more than one  grammatical system. If this occurs, then
;;; the  previous owner  is  disabled  and  plays  no  further role in
;;; generation or integrity  checking. The extensions here ensure that
;;; this  is handled sensibly  with  multiple  languages (since it  is
;;; quite possible that a single feature be  owned by distinct systems
;;; in distinct languages).
;;;

(declaim (special *disabled-systems* curlan))

;;; Following functions from system.lisp. They were not previously
;;; effected by the multilingual environment... An additional optional
;;; argument is added that gives the languages for which the
;;; disablement/enablement is to be considered. If no language
;;; is given, the system is considered disabled/enabled
;;; for the current language.

;;; 0.8: was relying on (list-systems) which already removes
;;;      disabled-systems!

(defun DISABLE-SYSTEM (&OPTIONAL System (lg curlan))
  (cond
    (System (setf (fetch-disabled-system System lg) T))
    (T 
     (loop for System in *disabled-systems*
	  when (member lg (cdr Systems)) collect System))))


;;; 
;;; 0.8: was missing the restricting to lg in (list-systems)

(defun ENABLE-SYSTEM (&OPTIONAL System (lg curlan))
  
  ;The preselection features are computed only for 
  ;enabled systems. Enabling a system may invalidate 
  ;them.
  (setq Paths-Valid NIL)

  (cond
    (System (setf (fetch-disabled-system System lg) NIL))
    (T (loop for System in (List-Systems lg) 
	    unless (fetch-disabled-system System lg) collect System))))


;;; ----------------------------------------------------------------------
;;; Old old utilities... (1.1 checked and updated)

(defun COMPUTE-SYSTEM-INPUT-FEATURES (Inputs)
  (cond ((listp inputs)
	 (loop for elt 
	     in (CDR Inputs) 
	     append (Compute-System-Input-Features elt)))
	((atom inputs)
	 (list Inputs))))

(defun COMPUTE-SYSTEM-OUTPUT-FEATURES (outputs)
  (mapcar #'second outputs))

(defun FETCH-SYSTEM-ENTER-FIRST-ASSOCIATIONS (system-name)
  (gethash system-name system-enter-first-associations))

(defun REPLACE-SYSTEM-ENTER-FIRST-ASSOCIATIONS 
    (system-name &optional new-value)
  (setf (gethash system-name  system-enter-first-associations) new-value))

(defsetf FETCH-SYSTEM-ENTER-FIRST-ASSOCIATIONS
    replace-system-enter-first-associations)

;;; 2.0 new utilities...
(defun NEGATIVE-FEATURE-OF (system)
  (loop for f in (fetch-output-features system)
      when (negative-feature-p f)
      do (return f)))

;;; ----------------------------------------------------------------------
;;; 0.9 following was not multilingual and was inefficient too. Changed and
;;;     incorporates the spririt of John Wilkinson's speed patches... The
;;;     hashtable *gate-table* now holds the list of languages for which the
;;;     system is in fact a gate (which can be different across languages).

(DEFUN Gate-P (Sys &optional (lg-variety curlan))
  (member lg-variety (gethash sys *gate-table*)))

(DEFUN Create-Feature-Def-Record NIL
    (make-Exact-Feature-Def))

;;; ----------------------------------------------------------------------
;;; Merging multiple language definitions...

(defun MERGE-NEW-AND-OLD-SYSTEM (name-para new-instance new-languages)
  (setf (system-language-set new-instance) new-languages)
  (when *show-loading-actions*
	       (format t "~%Loading system:  ~A" name-para))
  (cond ((and *merging-active*
	      (gethash (first name-para) system-table))
	 (let* ((name (first name-para))
		(old-instance (gethash name system-table))
		(old-languages (remove name (system-name old-instance)))
		(merged-instance nil)
		(old-lg-instance-pairs 
		 (create-set-of-mono-lingual-instances name :system))
		(new-lg-instance-pairs
		 (create-set-of-mono-lingual-instances new-instance :system)))

	   (when *show-loading-actions*
		 (format t "~%...merging; old languages: ~A; new languages: ~A" 
			 old-languages new-languages))

	   (cond ((equal new-languages old-languages)
		  (when (member :systems *show-merging-actions*)
			(format t "~%System ~A multiply defined, new definition wins."
				name))
		  (delete-system name)
		  new-instance)
		 ((intersection new-languages old-languages)
		  (when (member :systems *show-merging-actions*)
			(format t "~%Merging for system ~A; shared languages (old:~A; new:~A)" name old-languages new-languages))
		  (merge-overlapping-system-instances
		   name old-lg-instance-pairs new-lg-instance-pairs))

		 (t
		  (when (member :systems *show-merging-actions*)
			(format t "~%Merging for system ~A; disjunctive languages" name))
		  (delete-system name)
		  (setf merged-instance 
			(apply #'merge-system-instances 
			       (list
				(append old-lg-instance-pairs 
				        new-lg-instance-pairs))))

		  (when (and *step-by-step-merging-behavior*
			     (member :systems *show-merging-actions*))
			(format t 
				"~%***Merged: old instance: ~%     ~A~%~
  ***new instance: ~A~%  ***and merged:~A~%" old-instance new-instance merged-instance))
		  merged-instance))))
	(t
; if systems of same name exist for any of the current instance's
; language incarnations, then those systems have to be deleted.
; This is clearly disadvantageous since systems of name X in language
; L2 will cause any system of name X already defined for language
; L1 to be deleted. This option can be used for working on a
; new language development without regard for previous resources.
; Subsequently merging can be undertaken using the merging mode.
	 (let* ((sys-name (first name-para))
		(old-instance (gethash sys-name system-table)))
	   (when old-instance
		 (unless (subsetp (system-language-set old-instance) 
				  (cdr name-para))
			 (warning "Previously existing system: " sys-name
				  " is being overwritten by a definition with narrower language coverage: " (cdr name-para) " instead of " 
				  (system-language-set old-instance) "."))
		 (delete-system sys-name)))

; consider following for selective deletions some time maybe...
;	 (for eachone in name-para
;	      do
;	      (let ((name (first eachone))
;		    (lg   (second eachone)))
;		(when (system-defined-for-lg-p name lg)
;		      (when *show-loading-actions*
;			    (format t "~%  exists for language: ~A; overwriting" lg))
;		      (delete-system-for-lg name lg))))

	 (return-from merge-new-and-old-system new-instance))
	))


;;; Function for merging system definitions when they are both
;;; multilingual and even overlap in their language definitions...

;;; KPML-0.8 multiple merging added.
;;; The form of the serious arguments are lists of pairs, the first
;;; element gives the language, the second an instance of
;;; a system for that language. Virtually identical
;;; functions also defined below for choosers and 
;;; inquiries, and in ml-lexicon-merging for lexical
;;; items.

(defun MERGE-OVERLAPPING-SYSTEM-INSTANCES
  (name old-lg-instance-pairs new-lg-instance-pairs)
  
  (let ((merged-instance nil))
    (delete-system name)
    (setf merged-instance 
	  (apply #'merge-system-instances 
		 (list (replace-keyed-elements
			old-lg-instance-pairs 
			new-lg-instance-pairs))))
    
    (when (and *step-by-step-merging-behavior*
	       (member :systems *show-merging-actions*))
	  (format t 
		  "~%***Merged: old language instance pairs: ~%     ~S~%~
  ***new language instance pairs: ~S~%  ***and merged instance:~A~%" old-lg-instance-pairs new-lg-instance-pairs merged-instance))
    merged-instance))


(defun MERGE-SYSTEM-INSTANCES (list-of-lg-instance-pairs)
  (let ((instance   (generalized-merge-instance
		     list-of-lg-instance-pairs
		     '(system-name system-inputs system-outputs 
		       system-chooser system-selector
		       system-region system-metafunction
		       system-patch-status)
		     #'create-system)))
    (setf (system-language-set instance)
	  (mapcar #'first list-of-lg-instance-pairs))

;;; following ugliness is necessary because of gates and ml-expressions
;;; competing for the use of embeddings!
    (unless (wellformedness-check (system-outputs instance))
	    (setf (system-outputs instance) (list (system-outputs instance))))
    instance))


#||
;;; ... the following is just an example of what the generalized
;;; functions would expand into...

(defun expanded-merge-system-instances (list-of-lg-instance-pairs)
  (let ((merged-instance (create-system)))
    (setf (system-name Merged-Instance) (merge-lx lg1 (system-name i1)
						  lg2 (system-name i2)))

    (setf (system-inputs Merged-Instance) (merge-lx lg1 (system-inputs i1)
						    lg2 (system-inputs i2)))

    (setf (system-outputs Merged-Instance) (merge-lx lg1 (system-outputs i1)
						     lg2 (system-outputs i2)))

    (setf (system-chooser Merged-Instance) (merge-lx lg1 (system-chooser i1)
						     lg2 (system-chooser i2)))

    (setf (system-selector Merged-Instance) (merge-lx lg1 (system-selector i1)
						      lg2 (system-selector i2)))
    
    (setf (system-region Merged-Instance) (merge-lx lg1 (system-region i1)
						    lg2 (system-region i2)))
    
    (setf (system-metafunction Merged-Instance) (merge-lx lg1 (system-metafunction i1)
							  lg2 (system-metafunction i2)))
    Merged-Instance))
||#

;;; ----------------------------------------------------------------------
;;; List conversions...

(defun SYSTEM-INSTANCE-TO-LIST-MULTI-TO-MULTI (system)
  (list 
   (cond ((gate-instance-p system) 'gate) (t 'system))  ;; 3.2.2 used wrong gate-p
   :name (system-name system)
   :inputs (system-inputs system)
   :outputs (system-outputs system) 
   :chooser (system-chooser system)
   :region (system-region system) 
   :comments (system-comments system)   ;; 3.2.2
   :patch-status (system-patch-status system)
   :metafunction (system-metafunction system)))

(defun SYSTEM-INSTANCE-TO-LIST-MULTI-TO-MONO 
       (instance &optional (language-variety curlan))
  (list
    (cond ((gate-instance-p instance) 'gate) (t 'system))  ;; 3.2.2 did not check gate at all
    :name (strip-lx (parse-clause (system-name instance) language-variety))
    :inputs (strip-lx (parse-clause (system-inputs instance) language-variety))
    ;; stripping the following wrecks gates...
    :outputs (parse-clause (system-outputs instance) language-variety)
    :chooser (strip-lx (parse-clause (system-chooser instance) language-variety))
    :region (strip-lx (parse-clause (system-region instance) language-variety))
    :comments (strip-lx (parse-clause (system-comments instance) language-variety)) ;; 3.2.2
    :patch-status (strip-lx (parse-clause (system-patch-status instance) language-variety))
    :metafunction (strip-lx (parse-clause (system-metafunction instance) language-variety))))
    
  ;; 3.2.2 following two functions changed to be dependent on the two
  ;; above instead of being independent.

(defun SYSTEM-TO-LIST-MULTI-TO-MULTI (system-name)
  (system-instance-to-list-multi-to-multi (gethash system-name system-table)))

(defun SYSTEM-TO-LIST-MULTI-TO-MONO (system &optional (language-variety curlan))
  (cond ((system-defined-for-lg-p system language-variety)
         (system-instance-to-list-multi-to-mono 
          (gethash system system-table)))
	(t nil)))

;;; ---------------------------------------------------------------------
;;; Following information getters moved from allparts and other areas
;;; of generation code in Penman to here...

(DEFUN Get-System-Info (Sys Request)
  "Steve: 23-Mar-82  For efficiency, this 
   function MUST guarantee to return lists that can be 
   modified (NCONCed) at the top level."
  
  (Case Request (Name Sys)
	(Inputs (copy-tree (fetch-system-inputs Sys)))
	(Called-By (loop for Inp in (fetch-input-features Sys)
			with Res = nil
			do (SETQ Res (append (fetch-exact-Feature-def-field 'Chosen-By Inp)
					     Res))
			finally (RETURN (sort (copy-list (remove-Duplicates Res :test #'equal))
					      #'String-lessp))))
	(Calls (loop for Out in (fetch-output-features Sys) with Res = nil
		    do (SETQ Res (append (fetch-exact-Feature-def-field 'waiting out)
					 Res))
		    finally (RETURN (sort (copy-list (remove-Duplicates Res :test #'equal))
					  #'String-lessp))))
	(Inserts (Get-System-Output-Fields Sys 'Insert))
	(Conflations (Get-System-Output-Fields Sys 'Conflate))
	(Expansions (Get-System-Output-Fields Sys 'Expand))
	(Orderings (list-skipping-nils (Get-System-Output-Fields Sys 'Order)
			 (Get-System-Output-Fields Sys 'Orderatfront)
		      (Get-System-Output-Fields Sys 'Orderatend)
		      (Get-System-Output-Fields	Sys 'Partition)))
	(Preselections (Get-System-Output-Fields Sys 'Preselect))
	(Classifys (Get-System-Output-Fields Sys 'Classify))
	(Out-Classifys (Get-System-Output-Fields Sys 'OutClassify))
	(Lexifys (Get-System-Output-Fields Sys 'Lexify))
	(inflectifys (get-system-output-fields sys 'inflectify))
	(otherwise (Warning "Illegal System-Info request: " Request))))

(defun GET-SYSTEM-OUTPUT-FIELDS (sys field)
  (loop for Out in (fetch-System-Outputs sys)
       with Ans = nil
       do (loop for Each in (CDDR Out)
	        when (Eq (CAR Each) field)
	        do (Push  Each Ans))
       finally (RETURN (Dreverse Ans))))


;;; ----------------------------------------------------------------------
;;; 4.1 update of old-feature treatment here in order to improve
;;;     tracing behaviour. If the following flag gets turned off,
;;;     the new (function . feature) pairs are continually added
;;;     during generation. This could even be of some use for
;;;     getting a sense of how many features in what kinds of
;;;     distributions are used across a set of generation examples.

(defvar *CLEAR-OLD-FEATURES* T)

(defun CLEAR-OLD-FEATURES-OF-SYSTEMS ()
  (loop for s in (list-systems)
      do (setf (fetch-system-old-feature s) nil)))

(defun UPDATE-OLD-FEATURE-SELECTION (system chosen-feature)
  (declare (special *CURRENT-WHERE-AM-I*))
  (let ((old-value (fetch-system-old-feature system)))
    (if old-value
	(setf (fetch-system-old-feature system)
	      (append
	       old-value
	       (list (cons *CURRENT-WHERE-AM-I* chosen-feature))))
      (setf (fetch-system-old-feature system)
	    (list (cons *CURRENT-WHERE-AM-I* chosen-feature))))))

;;; ----------------------------------------------------------------------
;;; These old and no longer accurate... still a good idea to do this
;;; sometime though...

#||

(defun validate-system (system)
; checks that the system is well formed
  (let ((name (system-name system))
        (inputs  (system-inputs system))
        (outputs (system-outputs system)))
    (validate-system-inputs inputs name)
    (validate-system-outputs outputs name)
    (when (intersection (compute-system-input-features inputs) 
                        (compute-system-output-features outputs))
                        (Warning "Overlap between input and output features of " Name "."))))

(DEFUN validate-System-Inputs (Inputs sys-name)
;;;warning - added sys-name as parameter replacing a specvar
  (if (value-if-listp Inputs)
     (Case (CAR Inputs)
       ((and) (loop for elt in (CDR Inputs) do (Check-System-Inputs elt sys-name)))
       ((or)  (loop for elt in (CDR Inputs) do (Check-System-Inputs elt sys-name)))
       (otherwise (Warning "Illegal input form " Inputs " for System " Sys-Name "."))))
  Inputs)

(defun validate-system-outputs (outputs name)
; checks that system outputs are well formed
  (let ((sum 0.0))
    (loop for output-form in outputs
      do (let ((probability (first output-form))
               (feature (second output-form))
               (realizations (cddr output-form)))
           (setq sum (+ sum probability))
           (unless (atom feature)    ;check for atomic grammatical feature
             (warning "The system " name " has an invalid output specification: " output-form))
           (dolist (single-realization realizations)
             (cond ((atom single-realization)
                    (warning "The system " name " has an atomic realization: " single-realization))
                   ((not (member (first single-realization) operators))
                    (Warning "The system " name " has an invalid operator " 
                             (first single-realization) "."))))))
    (if (> (abs (- 1.0 Sum))  0.03)
	      (Warning "In system " name " -- Probabilities do not sum to 1"))))

||#
