;;
;;
;;      Title : D-ConvDeclarations
;;
;;      Function : Processes the declarations into their appropriate 
;;                 global variables.
;;
;;      Author : Alan W Black  7th Oct 1985
;;               Dept of A.I.  University of Edinburgh
;;
;;      Copyright Graeme Ritchie, Alan Black,
;;                Steve Pulman and Graham Russell  1987
;;
;;         ---------------------------------------------
;;         |    Not to be used for military purposes   |
;;         ---------------------------------------------
;;
;;      Description :
;;           This is the hacked remains of dclsconv version 1.10
;;      21st January 1986
;;         Changed the parsing to use a recursive decent parser
;;         This should run better.  An be less dependant on the 
;;         lisp syntax
;;      1.18 27th June 1986
;;         added the possible declaration of morpholgical only
;;         features.
;;      2.1  11th August 1986
;;         modified the syntax of the declarations to bring them more
;;         into line with those of the GDE and the GPSG book
;;         Added LCategory definitions
;;      2.2  9th October 1986
;;         Made keywords macros.
;;
;;         Reads in the declarations for the morpholgical analyser
;;         and translates them into a more regular form. Saves the
;;         declarations in various global variables
;;         This is called by both MakeWordGrammar and MakeLexicon
;;
;;      Parameters :
;;      Returns :
;;      Side Effect :
;;
;;      External references :
;;
;;      System functions used :
;;        Name     type      Args #  type                 Comment
;;
;;      Restrictions :
;;
;;

(declare
   (special
      D-FSD
      D-VARIABLES
      D-ALIASES
      D-WHEAD
      D-WDAUGHTER
      D-MORPHOLOGYONLY
      D-CATVALFEAT
      D-DISTINGUISHEDCATEGORY
      D-LCATEGORIES
   )
   (localf
      D-ParseDeclarations             
      D-ParseDcls                     
      D-ParseNonInflectCategories
      D-ParseNonInflect
      D-ParseAlias                    
      D-ParseVariable                 
      D-ParseFeature                  
      D-ParseDefaults                 
      D-ParseDefault                 
      D-CheckDefaultDeclarations      
      D-ExpandAliasesLCategory
      D-NormaliseAliases
      D-CheckSTEM                     
   )
)

(defun D-ParseDeclarations ()
;;
;;   cannot be recursive, as list could be very long.  Does
;;   recurse on include files though
;;
;;   Note that the normal stack cannot be used for holding
;;   D-fileid, because of possible problems if D-fileid is
;;   local rather than global
;;
   (let ()
      (D-while (memq D-CurrentSym 
	   (list (DK-Alias) (DK-Variable) (DK-Feature) (DK-NonInflect)
		 (DK-CatDef)
		 (DK-LCategory) (DK-FeatureClass) (DK-Defaults) (DK-Top)))
	 (D-ParseDcls)  ;; deal with declaration 
      )
      (D-CheckDefaultDeclarations)
   )
)

(defun D-ParseDcls ()    
;;
;;   This takes a declaration and adds it to the appropriate
;;   list
;;
   (let ()
      (cond
         ((eq D-CurrentSym (DK-Alias))
	    (D-GetNextSym)
	    (D-ParseAlias)
         )
         ((eq D-CurrentSym (DK-Variable))
	    (D-GetNextSym)
	    (D-ParseVariable)
         )
         ((eq D-CurrentSym (DK-Feature))
	    (D-GetNextSym)
	    (D-ParseFeature)
         )
         ((eq D-CurrentSym (DK-FeatureClass))
	    (D-GetNextSym)
	    (D-ParseFeatureClass)
         )
         ((eq D-CurrentSym (DK-Defaults))
	    (D-GetNextSym)
	    (D-ParseDefaults)
         )
         ((eq D-CurrentSym (DK-Top))
	    (D-GetNextSym)
	    (D-ParseTopCategory)
         )
	 ((eq D-CurrentSym (DK-NonInflect))
	    (D-GetNextSym)
	    (D-ParseNonInflect)
	 )
	 ((eq D-CurrentSym (DK-CatDef))
	    (D-GetNextSym)
	    (D-ParseCatDef)
	 )
         ((eq D-CurrentSym (DK-LCategory))
	    (D-GetNextSym)
	    (D-ParseLCategory)
         )
         (t
	    (D-FindCurrentLine)
	    (error
	       (concat "unknown declaration type " D-CurrentSym))
         )
      )
   )
)
   
(defun D-ParseNonInflect ()
;;
;;  Parses a declaration of a category type that is non-inflectable
;;  This consists of either a category or a list of categories.
;;  Any entries which are extensions of these categories are marked
;;  as being uninflectable in any way (derivation, compound etc) 
;;  These entries are treated as complete words and can never be found
;;  as part of another word nor can match any part of the word grammar
;;
   (D-MustHave '=)
   (D-MustHave D-LEFTBRACE)
   (setq D-NONINFLECTS (D-ParseNonInflectCategories))
   (D-MustHave D-RIGHTBRACE)
)

(defun D-ParseNonInflectCategories ()
;;
;;   parses a list of categories separated by commas and terminated by a right
;;   brace
;;
   (cond
      ((eq D-CurrentSym D-RIGHTBRACE)
	 nil   ;; needed for case when an empty set is given
      )
      (t
	 (let ( (element (D-ParseCategory)) )
	    (cond
	      ((eq D-CurrentSym D-COMMA)
		 (D-GetNextSym)
		 (cons element (D-ParseNonInflectCategories))
              )
	      ((eq D-CurrentSym D-RIGHTBRACE)
		 (ncons element))
              (t
	          (D-FindCurrentLine)
	          (error (concat "Comma or right brace expected but "
				 D-CurrentSym " found"))))))
   )
)

(defun D-ParseAlias ()
;;
;;  This parses an alias declaration and adds it to the ALIAS
;;  list, consistancy checks are done later
;;
   (let (  (aliasname D-CurrentSym)
	   (aliasvalue nil) )
      (D-CheckAtom aliasname)   ;; ensure not a bracket etc
      (D-GetNextSym)  
      (D-MustHave '=)
      (setq aliasvalue (D-ParseCategory))
      (setq D-ALIASES 
	 (cons
	    (list aliasname aliasvalue)
	    D-ALIASES))
   )
)

(defun D-ParseVariable ()
;;
;;  This parses a variable declaration and adds it to the VARIABLES
;;  list, consistancy checks are done later
;;
   (let ( (variablename D-CurrentSym)
	  (variablevalues nil) )
      (D-CheckAtom variablename)   ;; ensure not a bracket etc
      (D-GetNextSym) 
      (D-MustHave '=)
      (cond
	 ((memq D-CurrentSym (list (DK-CAT) (DK-category)))
	    (setq variablevalues (DK-category))
	    (D-GetNextSym))
	 (t
	    (setq variablevalues (D-ParseSimpleSet)))
         )
      (setq D-VARIABLES
	 (cons
	    (list variablename variablevalues)
	    D-VARIABLES))
   )
)

(defun D-ParseFeature ()
;;
;;  This takes a feature declaration and adds it to the FEATURES
;;  list, consistancy checks are done later
;;
   (let ( (featurename nil)
	  (featurevalue nil) )
      (D-CheckAtom D-CurrentSym)
      (setq featurename D-CurrentSym)
      (D-GetNextSym)    ;; skip to category
      (cond         ;; is it a category valued feature
	 ((memq D-CurrentSym (list (DK-CAT) (DK-category)))
	    (setq D-CATVALFEAT (cons featurename D-CATVALFEAT))
	    (setq featurevalue (DK-category))
	    (D-GetNextSym)
	 )
	 (t         ;; must be an atomic valued feature
	    (setq featurevalue (D-ParseSimpleSet))
	 )
      )
      (setq D-FEATURES
	 (cons
	    (list featurename featurevalue)
	    D-FEATURES))
   )
)

(defun D-ParseDefaults ()
;;
;;   Parses the list of default declarations 
;;
   (let ( )
      (setq D-FSD (ncons (D-ParseDefault)))
      (D-while (eq D-CurrentSym D-COMMA)
	 (D-MustHave D-COMMA)
	 (setq D-FSD (cons (D-ParseDefault) D-FSD))
      )
   )
)

(defun D-ParseDefault ()
;;
;;   parses a default (which is simply a feature and a value)
;;
   (let ( feat value )
      (setq feat D-CurrentSym)
      (D-CheckAtom feat)
      (D-GetNextSym)
      (setq value D-CurrentSym)
      (D-CheckAtom value)
      (D-GetNextSym)
      (list feat value)
   )
)

(defun D-CheckDefaultDeclarations ()
;;
;;   This checks any stiputaltion in the declarations and/or
;;   adds the defaults
;;
   (D-CheckSTEM)
   (D-CheckTopCat)
   (D-NormaliseAliases (copy D-ALIASES))
   (setq D-DISTINGUISHEDCATEGORY
      (D-CheckDistCat D-DISTINGUISHEDCATEGORY))
   (setq D-LCATEGORIES
      (D-ExpandAliasesLCategory D-LCATEGORIES))
   (setq D-NONINFLECTS
      (mapcar
	 #'(lambda (cat) (D-MakeCategory (D-SubsAliasCategory cat)))
	 D-NONINFLECTS))
)

(defun D-ExpandAliasesLCategory (lcats)
;;
;;   expands all the aliases in categories in these definitions
;;
   (mapcar
      #'(lambda (lcat)
	 (cond
	    ((eq (length lcat) 3)  ;; a category value lcat
	       (list 
		  (car lcat)
		  (D-SubsAliasCategory (cadr lcat))
		  (caddr lcat))
            )
	    (t                   ;; a normal one
	       (list
		  (D-SubsAliasCategory (car lcat))
		  (cadr lcat)))))
      lcats
   )
)

(defun D-NormaliseAliases (aliases)
;;
;;   This expands all the aliases to their fully expanded form.
;;   If an alias expands to include itself a warning is generated
;;   and the alias is droped from the alias list.
;;
;;   Not this modifies the global D-ALIASES
;;
   (cond
      ((null aliases) nil)
      (t
	 (let ( (name (caar aliases)) (value (cadar aliases)) )
	    (setq D-ALIASES
	       (cons
		  (list name (D-ExpandAliasCat value (ncons name)))
		  (D-RemoveAlias
		     name D-ALIASES)))
            (D-NormaliseAliases (cdr aliases))
         )
      )
   )                          ;; copy the list to be safe
)
 
(defun D-CheckSTEM ()
;;
;;    STEM must be decalred as a category valued feature
;;
   (cond
      ((D-CatValFeatP (DK-STEM))   ;; this should be true
	 t
      )
      ((D-FeatureP (DK-STEM))      ;; this should not be true
	 (error "STEM must be category valued")
      )
      (t                       ;; add declaration
	 (setq D-FEATURES
	    (cons
	       (list (DK-STEM) (DK-category))
	       D-FEATURES))
	 (setq D-CATVALFEAT
         (cons
	    (DK-STEM)
	    D-CATVALFEAT
         ))
      )
   )
)

