;;
;;
;;      Title : D-ParseRules      
;;
;;      Function :  parses the spelling rules to set lisp global
;;         variables with the information.
;;
;;      Author :  Alan W Black   June 1986
;;     
;;      Copyright : Graeme Ritchie, Alan Black,
;;                  Steve Pulman and Graham Russell  1987
;;
;;         ---------------------------------------------
;;         |    Not to be used for military purposes   |
;;         ---------------------------------------------
;;
;;      Description :
;;       This has been added at version 1.18 to replace the yacc and
;;       lex programs that were used in earlier versions.  It was 
;;       decided that it was better if the system could be contained
;;       wholly within lisp rather than using alien C routines.      
;;
;;      Parameters :
;;           none
;;      Returns :
;;           ?
;;      Side Effect :
;;           uses the global D-FILEID which has as its value the port
;;           open to the spelling rules file.
;;           Sets a number fo global variables with the necessary information
;;
;;      External references :
;;
;;      System functions used :
;;        Name     type      Args #  type                 Comment
;;
;;      Restrictions :
;;
;;

(declare
   (special 
      D-SURFACEALPHABET
      D-LEXICALALPHABET
      D-SURFACESETS
      D-LEXICALSETS
      D-DEFAULTPAIRS
      D-SPELLINGRULES)
   (localf
      D-ParseRules                    
      D-ParseEnumeratedSet            
      D-ParseSetDcl                   
      D-ParsePair                     
      D-ParseSpRule                   
      D-ParseOperator                 
      D-ParseContexts                 
      D-ParseORopt                    
      D-ParseContext                  
      D-ParsePairSequence             
      D-ParsePairList                 
      D-ParseWhereClause              
      D-CheckSetNames
   )
)

(defun D-ParseRules ()
;;
;;  This parses the basic input and sets global variables for the 
;;  required values.
;;
   (let ()
      (D-MustHave (DK-SurfaceAlphabet))
	 (setq D-SURFACEALPHABET (D-ParseEnumeratedSet))
      (D-MustHave (DK-SurfaceSets))
	 (D-while (not (eq D-CurrentSym (DK-LexicalAlphabet)))
	    (setq D-SURFACESETS (cons (D-ParseSetDcl) D-SURFACESETS))
         )
	 (D-CheckSetNames D-SURFACESETS D-SURFACEALPHABET 'surface)
      (D-MustHave (DK-LexicalAlphabet))
	 (setq D-LEXICALALPHABET (D-ParseEnumeratedSet))
      (D-MustHave (DK-LexicalSets))
	 (D-while (not (eq D-CurrentSym (DK-DefaultPairs)))
	    (setq D-LEXICALSETS (cons (D-ParseSetDcl) D-LEXICALSETS))
         )
	 (D-CheckSetNames D-LEXICALSETS D-LEXICALALPHABET 'lexical)
      (D-MustHave (DK-DefaultPairs))
	 (D-while (not (eq D-CurrentSym (DK-Rules)))
	    (setq D-DEFAULTPAIRS (cons (D-ParsePair) D-DEFAULTPAIRS))
         )
      (D-MustHave (DK-Rules))
	 (D-while (not (eq D-CurrentSym 'EOF))
	    (setq D-SPELLINGRULES (cons (D-ParseSpRule) D-SPELLINGRULES))
         )
	 (setq D-SPELLINGRULES (nreverse D-SPELLINGRULES))  ;; put dcl'd order
      (setq D-SURFACESETS    ;; a set of all feasible characters
	 (cons
	    (list
	       (gensym)    ;; any name
	       (cons (DK-NULL) D-SURFACEALPHABET))
            D-SURFACESETS)
      )
   )
)

(defun D-ParseEnumeratedSet ()
;;
;;  parses a set of atoms within braces, returns the set in a list
;;
   (let (list)
      (D-MustHave D-LEFTBRACE)
      (D-while (not (eq D-CurrentSym D-RIGHTBRACE))
	 (D-CheckAtom D-CurrentSym)  ;; check its not parentheses
	 (setq list (cons D-CurrentSym list))
	 (D-GetNextSym)
      )
      (D-MustHave D-RIGHTBRACE)
      (nreverse list)   ;; return it in the order it was stated
   )
)

(defun D-ParseSetDcl ()
;;
;;   parse a set declaration and return it in the form (name (list ...))
;;
   (let (name)
      (setq name D-CurrentSym)
      (D-GetNextSym)
      (D-MustHave (DK-is))
      (list name (D-ParseEnumeratedSet))
   )
)

(defun D-ParsePair ()
;;
;;  parses a lexical and surface pair.  and returns it in a list.
;;
   (let (lexch surfch)
      (setq lexch D-CurrentSym) 
      (D-GetNextSym)
      (D-MustHave D-COLON)  ;; skip over the colon separator
      (setq surfch D-CurrentSym)
      (D-GetNextSym)
      (list lexch surfch)
   )
)

(defun D-ParseSpRule ()
;;
;;  returns a spelling rule in the required normal form
;;
   (let (name rpair op contexts whereclause)
      (setq name D-CurrentSym) (D-GetNextSym)
      (setq rpair (D-ParsePair)) ;; the rule pair
      (setq op (D-ParseOperator))
      (setq contexts (D-ParseContexts))
      (setq whereclause (D-ParseWhereClause))
      (list
	 name rpair op contexts whereclause)
   )
)

(defun D-ParseOperator ()
;;
;;  check the current symbol is => <= or <=>
;;
   (let ( (op D-CurrentSym) )
      (cond
	 ((eq D-CurrentSym '=)
	    (D-GetNextSym)
	    (cond
	       ((eq D-CurrentSym '>)
		  (D-GetNextSym)
	          '=>         ;; context restriction
               )
	       (t (D-FindCurrentLine)
		  (error "=> expected but not found"))))
         ((eq D-CurrentSym '<)
	    (D-GetNextSym)
	    (cond
	       ((eq D-CurrentSym '=)
		  (D-GetNextSym)
		  (cond
		     ((eq D-CurrentSym '>)
			(D-GetNextSym)
			'<=>)    ;; complex rule
                     (t '<=)     ;; surface coercion
                  )
               )
	       (t  (D-FindCurrentLine)
		   (error "= expected in operator but not found"))))
	 (t
	    (D-FindCurrentLine)
	    (error (concat op " found when an opertor expected"))
         )
      )
   )
)

(defun D-ParseContexts ()
;;
;;   Parses contexts
;;
   (let (contexts)
      (D-repeat (
	 (setq contexts (cons (D-ParseContext) contexts))
	 )
	 until (D-ParseORopt)
      )
      (nreverse contexts)
   )
)

(defun D-ParseORopt ()
;;
;;  If the current symbol is 'or return nil and skip to next symbol,
;;  otherwise return t   
;; 
   (let ()
      (cond
	 ((eq D-CurrentSym (DK-or))
	    (D-GetNextSym)
	    nil
         )
	 (t t)
      )
   )
)

(defun D-ParseContext ()
;;
;;   parses a context
;;
   (let (lhs rhs)
      (setq lhs (D-ParsePairSequence))
      (D-MustHave '---)
      (setq rhs (D-ParsePairSequence))
      (list lhs rhs)
   )
)

(defun D-ParsePairSequence ()
;;
;;  parses a regular expression of pairs in a context
;;
   (let  (subexpr)
      (cond
	 ;; this ones would introduce nulls into the automata
	 ;; so I chickened out - I'd have to do another pass
	 ;; during compilation it would take too long - sorry
	 ;; I don't loose any generality though
         ;((eq D-CurrentSym D-LEFTPAREN)   ;; optional
	    ;(D-MustHave D-LEFTPAREN)
	    ;(setq subexpr (D-ParsePairSequence))
	    ;(D-MustHave D-RIGHTPAREN)
	    ;(list 'OPT subexpr)
         ;)
         ((eq D-CurrentSym D-LEFTPAREN)   ;; kleene plus
	    (D-MustHave D-LEFTPAREN)
	    (setq subexpr (D-ParsePairList))
	    (D-MustHave D-RIGHTPAREN)
	    (cond
	       ((eq D-CurrentSym (DK-KleenePlus))
		  (D-GetNextSym)
	          (cons '1+ subexpr))
               (t
		  (D-MustHave (DK-KleenePlus)))
            )
         )
         ((eq D-CurrentSym D-LEFTBRACE)   ;; choice
	    (D-MustHave D-LEFTBRACE)
	    (setq subexpr (D-ParsePairList))
	    (D-MustHave D-RIGHTBRACE)
	    (cons 'OR subexpr)
         )
         ((eq D-CurrentSym D-LEFTANGLE)   ;; sequence
	    (D-MustHave D-LEFTANGLE)
	    (setq subexpr (D-ParsePairList))
	    (D-MustHave D-RIGHTANGLE)
	    (cons 'SEQ subexpr)
         )
	 (t                               ;; must be simple pair
	    (D-ParsePair)
         )
      )
   )
)

(defun D-ParsePairList ()
;;
;;  parse list of complexitems
;;
   (cond
      ((memq D-CurrentSym (list D-RIGHTANGLE D-RIGHTBRACE D-RIGHTPAREN))
	 nil
      )
      (t    ;; the let* is to enforce Left to right evaluation for Camb Lisp
	 (let* ( (first (D-ParsePairSequence))
		 (rest (D-ParsePairList)) )
	    (cons first rest)
         )
      )
   )
)

(defun D-ParseWhereClause ()
;;
;; parses the optional where clause 
;;
   (let (wherevar whereset)
      (cond
	 ((eq D-CurrentSym (DK-where))
	    (D-MustHave (DK-where))
	    (setq wherevar D-CurrentSym) (D-GetNextSym)
	    (D-MustHave (DK-in))
	    (setq whereset (D-ParseEnumeratedSet))
            (list wherevar whereset)
         )
	 (t nil)   ;; no where clause
      )
   )
)

(defun D-CheckSetNames (sets alphabet type)
;;
;;   Checks that no set name is also an alphabet member
;;
   (mapc
      #'(lambda (name)
	 (cond
	    ((memq name alphabet)   
	       (error (concat "confused: \"" name "\" is both a " type
			 " setname and an alphabet character")))
            (t nil)))
      (mapcar #'car sets))
)
