;;; -*- Mode:Lisp; Package:DYPAR; Base:10; -*-

;;;		  LastEditDate =  11:41:29  Thu, 31-Aug-89  -- Mark Boggs

;;; ----------------------------------------------------------------
;;; 
;;; 		(c) Copyright, 1984,
;;; 			by Jaime Carbonell, Mark Boggs, Scott Safier,
;;;			   Stephen Morrisson, and Demetri Silas.
;;; 			All rights reserved
;;; 
;;; ----------------------------------------------------------------

;;; XREF.LSP

;;; HISTORY
; 27-Feb-01 Moises Gil&Nuria Ripoll
; 	Añadimos a la funcion "x-pat", el tratamiento del nuevo operador "<-".
;
; 23-Feb-01 Moises Gil&Nuria Ripoll
;	Cambiamos de nombe la funcion "erase-gra" por "erasegra"
;
; 8-Nov-00 Moises Gil&Nuria Ripoll
;  	Comentamos las siguientes variables, ya definidas en "xload.lsp"
;  	!!not-defined, !!patrules, !!pattrans
;
; 24-Aug-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Made changes to the messages in cross-reference so that file
;		names are retruned and empty messages don't appear.
;	Added xref support for !!recorules.
;	Fixed bug in setting of !!terminals
;
; 09-Aug-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Made loadgra quit writing over $ and $n values for multiple files.
;
; 08-Aug-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Reinstalled new versions of the incremental xreferencing functions:
;	x-ancestors, x-optional and x-ancestory
;
; 02-Aug-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Changed behaviour of undefined non-terminals by creating
;	an empty structure to "hold their place" in the structure
;	hash table.
;
; 04-May-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Moved sorting routines to general.lsp
;	Removed references to old-style morphology.
;
; 03-May-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Fixed problem with undefined nonterminals trying to update
;	non-existent structures which caused the lisp to break
;
; 02-May-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Added computation of :consumed, :required and :constants to
;		functions x-pat and x-ref.
;	Converted x-reference to return multiple values.
;
; 18-Apr-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Added processing for !!non-pattern-operators
;
; 17-Apr-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Added function process-terminal to take care of the
;	bookkeeping needed to add a new terminal to the grammar.
;	The function places the terminal in *dypar-terminal-hash*
;	as well as *dypar-terminal-array*
;
; 16-Apr-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Converted functions x-pat and x-ref to return multiple values.
;	Commented the x-pat function.
;	Removed the &morph x-pat clause (to file exmorph.lsp)
;	Changed name of $-p to wildcard-p to avoid confusion.
;
; 09-Apr-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Fixed bug with $n by adding it to the terminals hash-table.
;	Added function show-gra.
;	Fixed duplication problem in !!patrules, !!pattrans and !!nonterms.
;	Fixed message in loadgra.
;	Converted to used message definitions in babel.lsp.
;
; 07-Apr-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Added support for &a
;	Changed &i to be smarter about empty patterns
;	Added xref support for user defined operators using the symbol prop.
;
; 03-Apr-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Fixed fwild assignment in &ui (now t)
;
; 19-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Changed calls to alphalessp to calls to string-lessp
;
; 18-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Changed the rewrite property to the pattern structure slot so
;	as to conserve slots in the structure.  The structure definitions
;	and explanations are included in the file struc.lsp.  This 
;	set of changes supercedes the manual documentation about the
;	Xreference implementation.  To this end the comments in the running
;	code have been expanded.
;	Changed ptrace calls to use the new format based definition of ptrace
;	Changed nontermp and rul-p to use char= and char directly.
;
; 16-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Removed Fly reference functions to the file flyxref.lsp.
;	Started translation to lisp structures.
;	Changed msg calls to format calls.
;	Added package support.
;
; 15-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Converted to GCL3.1 format
;	Changed calls to memq, last, putprop
;
; 08-Dec-84  Mark Boggs (wmb) at Carnegie-Mellon University
;	Added &o and &sc to xref.
;
; 27-Nov-84  Mark Boggs (wmb) at Carnegie-Mellon University
;	Added &bu and &frame to xref.  Also fixed &ui.  Merged in Common
;	Lisp changes.  Most of the interactive update stuff will not
;	work in Common Lisp.
;
; 2-June-84 Demetri Silas at Carnegie-Mellon University
;       fixed the defining of rules on the fly. Added the rem-nonterm, 
;       rem-rule, and rem-trans so that rules can be removed on the fly.
;       Also added on the fly rule defining updating to a file. Two functions
;       are used; open-gra-file and close-gra-file. Note: the defining of 
;       rules, prompt the user for the parts of the rule presently. This
;       is done so that the verticle bar can be transformed to a "!" on the 
;       read. If you want to by pass the prompting you must use the "!". The
;       code change is trivial with the function read-pat, which is in that
;       area. (ex. (taltprop (readpat nonterm)) )
;
; 15-May-84 Mark Boggs & Demetri Silas at Carnegie-Mellon University
;       add Sorting List Manipulation functions so that all the property
;       lists can be sorted alphabetically. This speeds up things a bit 
;       because there is no need to go back and condense the lists (i.e.
;       insert it if it doesn't already exsist).
;
; 24-Apr-84 Demetri Silas (silas) at Carnegie-Mellon University
;       added new properties (:fwild and :lwild) for non-terminals.
;       These are boolean properties, if the non-terminal or pattern
;       has a wild in it's first or lasts position then these properties
;       are set to t. This makes the search for firsts and lasts 
;       non-deterministic on wilds. That's right the :first and :last
;       properties now contain the firsts and lasts and the "$" symbol if the 
;       non-terminal's or pattern's first and last are wild. Both x-pat and 
;       x-ref set fwild and lwild. They both return these varibles in 
;       their return list. Also x-pat was changed so when the wild setting 
;       is met the search for first and last continues. The $append and 
;       $delete-duplicates had to be changed so that the list of firsts and 
;       lasts properties can include the "$" symbol.
;
; 10-Apr-84 Demetri Silas (silas) at Carnegie-Mellon University
;       Converted Common Lisp version into this Franz Lisp version.
;       On the way two bugs were fixed. In x-ref when a non-terminal that
;       has to be rewritten is encountered the delete-firsts varible 
;       must be set to nil so that the previously found parse information
;       is not passed back up to the the nonterm being x-referenced. The 
;       second bug was in cross-reference. The not-used variable must be set 
;       after x-referencing top-level rules and trans rules, not just the 
;       first of the two. Thus a new global var was made !!not-used-nts and 
;       the defining is now done where the error message code is.
;
; 21-Feb-84  Scott Safier (ss) at Carnegie-Mellon University
;	Added new properties to be found while cross-referencing.  A
;	complete list of properties now assigned during
;	cross-referencing is:
;	
;	1) :first - a list of terminals of which occur in the first
;	       position of the non-terminal or pattern.
;        
;       2) :fwild - this boolean is true if the first position of the 
;              non-terminal or pattern can be wild.
;	
;	3) :last - a list of terminals of which occur in the last
;	       position of the non-terminal or pattern.
;	
;       4) :fwild - this boolean is true if the first position of the 
;              non-terminal or pattern can be wild.
;
;	5) :terminals - a list of terminals that appear in this
;	       non-terminal.  terminals appearing in non-terminals
;	       expanded from the pattern are not listed.
;	
;	6) :variables - a list of variables that occur in this
;	       non-terminal.
;	
;	7) :fchildren - a list of non-terms expanded to create the
;	       :first property
;	
;	8) :lchildren - a list of non-terms expnded to create the
;	       :last property
;
;       9) :parents - a list of non-terms that this non-term is a child to.
;
;       10) :opt - this boolean is true iff the nonterm is optional
;	
;	rules have similar properties to non-terminals
;
;  9-Feb-84  Scott Safier (ss) at Carnegie-Mellon University
;	Added 3 user interesting routines: defnonterm def-rule and
;	def-trans.  These three routines allow a user to define a
;	nonterminal, rule and transition respectively.  all indexing and
;	cross-referencing are done when the macro is invoked.
;	
;	the bnf for the defnonterm is
;	(defnonterm <nt-atom> ?<rewrite>)
;	<nt-atom> == <lisp-atom> ! <nonterminal>
;	<rewrite> == anything that evaluates to a rewrite in EXTERNAL
;	form
;	
;	(def-rule <rewrite> <action>)
;	<action> == any legal action
;	
;	(def-trans <rewrite> <action>)
;
;  7-Feb-84  Scott Safier (ss) at Carnegie-Mellon University
;	added new properties (:fchildren and :lchildren). These
;	properties contain all the non-terminals that were expanded to
;	create the :first and :last properties.  Changed
;	clear-x-ancestory to x-ancestory.  This function now does
;	incremental grammar loading using the following algorithm:
;	1) if a non-terminal (nt) is being loaded "on-the-fly", then
;	2) check the parents (P) of nt.  if nt occurs in either the
;	:fchildren or :lchildren property of P, then
;	$UNION the :first (and/or :last) of the parent, and recur trying
;	the nt on the parents of P.
;	3) If nt is not in either property of P, then return.
;	
;	by 'on-the-fly', I mean when an nt is being loaded after a
;	grammar that used it has been loaded.
;	
;	added $union from old cross-referencer
;	
;	added variable !!pat-vars.  This variable contains all of the
;	user-variables contained in the grammar.  each variable is
;	initialized to nil.
;
; 24-Jan-84  Scott Safier (ss) at Carnegie-Mellon University
;	Created.  This file contains the cross-referencer for dyparI.
;	The cross-reference preprocesses grammars to make dypar more
;	efficient.  The cross referencer determines, for every rule,
;	transformation rule, and nonterminal, the terminals which are
;	its firsts and lasts (stored in the properties :first and
;	:last).  Also, for every terminal and nonterminal, its 
;	parents are recorded.  Then the first and last terminals are
;	indexed to find the rules in which they occur.
;


;;; Compiler declarations

(in-package "DYPAR"); :use '("LISP" "USER"))

(eval-when (compile)
    (if (not (boundp '*macros-loaded*)) (load "macros"))
    (if (not (boundp '*struc-loaded*)) (load "struc"))
    (if (not (boundp '*babel-loaded*)) (load "babel")))

;;; We make use of a number of special variables introduced elsewhere.
(proclaim '(special
	!ptrace !!nonterms !!patrules !!pattrans !!recorules
	!!not-defined !!fly-file !!fly-port !!only-rewrites
	!!firsts !!lasts !!terminals !!multiple-nts
	!!used-nonterms !!not-used-nts 
	!!files-loaded !!pat-vars
	!!nodes *dypar-terminal-array*
	!!nonterms-used))


;;; set to nil when using DYPAR1.  If a different top-level is to be
;;; used in place of top-level rules, this variable should be set to t.
(defvar !!only-rewrites nil)

;;; variable that contains all the files currently loaded
(defvar !!files-loaded nil)

;;; varible containing all variable names used in a grammar
(defvar !!pat-vars nil)

;;; array which holds the terminals in a form used by the spelling fns.
(defvar *dypar-terminal-array*
  (make-array 20 :element-type 'list :initial-element nil))

;;; variables to keep track of all the used nonterminals
(defvar !!used-nonterms nil)
(defvar !!nonterms-used nil)

;;; variable to keep track of all the not used nonterminals
(defvar !!not-used-nts nil)

;;; variable to keep track of all the not defined nonterminals
;;------------------------ nuria-moisés -------------------------
;(defvar !!not-defined nil)     ; ya definida en xload.lsp
;;---------------------------------------------------------------

;;; the sets of all terminals, firsts and lasts that appear in
;;; in a running system.
(defvar !!terminals nil)
(defvar !!firsts nil)
(defvar !!lasts nil)

;;; the two globals used for the on the fly updating to a file
;;; NOTE:  MOVE THESE TO FLYXREF WHERE THEY BELONG.
(defvar !!fly-file nil)
(defvar !!fly-port nil)

;;; the set of cross-referenced rules, transformatations, and non-terminals
;;------------------------ nuria-moisés -------------------------
;(defvar !!patrules nil)     ; ya definida en vars.lsp
;(defvar !!pattrans nil)     ; ya definida en vars.lsp
;;---------------------------------------------------------------
(defvar !!recorules nil)


;;; rul-p
;;; predicate: returns t if the thing is a rule symbol.  We check the hash
;;; table to verify that there is an entry for the symbol.
(defun rul-p (thing)
  (and (symbolp thing)
       (top-level-rule-p (get-rule-hash thing))))

;;; nontermp
;;; predicate: returns t if the thing is a nonterminal.  A symbol is a
;;; nonterminal if it has, either a hash table entry or it starts and
;;; ends with angle brackets.
(defun nontermp (thing)
  (if (and (symbolp thing)
	   (or (non-terminal-p (get-rule-hash thing))
	       (and (char= #\< (char (symbol-name thing) 0))
		    (char= #\> (char (symbol-name thing)
				     (1- (length (string thing))))))))
      t))

;;; wildcard-p
;;; predicate: returns t if thing is any one of the wildcards.
;;; A number is treated as a wild card because of our inability
;;; to treat numbers as symbols.
(defun wildcard-p (thing)
  (or (member thing '($ $d $n $r $w))
      (numberp thing)
      (and (symbolp thing)
	   (get thing :symbol))))

(add-message 'cross-reference5
  :english "    for:  ~S~&"
  :spanish "    para:  ~S~&"
  )

;;; cross-reference
;;; the top level function, x-references all three rules, sets global
;;; variables, warns about not used non-terms and not-defined non-terms, 
;;; does the indexing
(defun cross-reference (file-name)
  (let ((pat-rules-var (new-patrules file-name))
	(pat-reco-var (new-recovers file-name))
	(pat-trans-var (new-pattrans file-name)))

    ;; cross reference all the rules and define global variables
    (multiple-value-bind (first last terms)
	(x-reference pat-rules-var "=> top-level rules:")
      (setq !!terminals (dy-merge terms !!terminals)
	    !!firsts (quick-condense first)
	    !!lasts (quick-condense last)))

    ;; cross reference all transformation rules
    (multiple-value-bind (first last terms)
	(x-reference pat-trans-var "::> transformation rules:")
      (declare (ignore first last))
      (setq !!terminals
	    (dy-merge terms ;(delete-if (function wildcard-p) terms)
		      !!terminals)))

    ;; cross reference all the recovery rules and define global variables
    (multiple-value-bind (first last terms)
	(x-reference pat-reco-var "=> recovery rules:")
      (declare (ignore first last))
      (setq !!terminals (dy-merge terms !!terminals)))

    ;; cross reference any nonterminals that haven't been cross
    ;; referenced
    (cond ((setq !!not-used-nts (setdiff !!nonterms !!used-nonterms))
	   (multiple-value-bind (first last terms)
	       (x-reference !!not-used-nts "-> rewrite rules:")
	     (setq
	       !!terminals
	       (dy-merge terms ;(delete-if (function wildcard-p) terms)
			 !!terminals)
	       !!firsts
	       (dy-merge (quick-condense first) !!firsts)
	       !!lasts
	       (dy-merge (quick-condense last) !!lasts)))

	   (cond ((and !ptrace (not !!only-rewrites) pat-rules-var)
		  (terpri)
		  (smformat 'cross-reference1)
		  (mapcar (funl (x)
			    (format t "~S -> ~S~&"
				    x (get-pattern x)))
			  !!not-used-nts)))))

    ;; warn about not defined non-terminals
    (if (and !ptrace !!not-defined)
	(smformat 'cross-reference2 !!not-defined))
    ;; index rules
    (smptrace 'cross-reference3)
    (dolist (r pat-rules-var)
      (if (listp (get-first r))
	  (dolist (first (get-first r))
	    (add-where first r)
	    (ptrace "F-"))
	  (add-where '$ r))
      (if (listp (get-last r))
	  (dolist (last (get-last r))
	    (add-lwhere last r)
	    (ptrace "L-"))
	  (add-lwhere '$ r)))
    (smptrace 'cross-reference4)
    (smptrace 'cross-reference5 file-name)))

;;; x-reference
;;; given a list of symbols and a property (which should reference a pattern)
;;; this function looks at the property for each symbol, and cross-references
;;; each pattern. It then returns a list of the firsts lasts and terms that
;;; were found on the way.
(defun x-reference (pattern-list id-str)
  (let ((firsts) (lasts) (terms))
    (or (null pattern-list)
	(smptrace 'x-reference1 id-str))
    (dolist (rul-tra-nt pattern-list

			;; the exiting operation
			(values firsts lasts terms))

      (ptrace "R")

      ;; setting existing variables
      (multiple-value-bind (f fw l lw tm opt v)
	  (x-ref (get-pattern rul-tra-nt) rul-tra-nt rul-tra-nt nil)
	(setq firsts (dy-merge (set-first rul-tra-nt f)
			       firsts)
	      lasts (dy-merge (set-last rul-tra-nt l)
			      lasts)
	      terms (dy-merge tm terms))
	(set-terminals rul-tra-nt tm)
	(set-fwild rul-tra-nt fw)
	(set-lwild rul-tra-nt lw)
	(set-opt rul-tra-nt opt)
	(set-variables rul-tra-nt v)))))


;;; X-PAT processes patterns (lists) returning values corresponding to
;;; the terminals symbols which can begin or end the pattern;
;;; terminals and variables introduced in the pattern; flags relating
;;; to the pattern's optionality or ability to match as a wildcard;
;;; and lists of nonterminals expanded to compute the above values.
;;; This function is called by the function X-REF.
;;; The arguments:
;;;	pat => a DYPAR pattern
;;;	parent => the source of this pattern (nonterminal)
;;;	active-nt => either a non-terminal or nil.
;;;		control for left recursion.
;;;	nt-stack => a stack of currently open non-terminals
(defun x-pat (pat parent active-nt nt-stack)
  (ptrace "o")
  
  ;; As the car of the patterns passed to this function are supposed
  ;; to be DYPAR operators, we build a case statement to process
  ;; each of the operators, based on its own peculiarities.
  (case (car pat)

    ;; As these two operators do not necessarily consume any input
    ;; we must make sure that they are viewed as optional and wild
    ((&u &bu)
     (multiple-value-bind
	   (firsts fwild lasts lwild terms optional-p vars)
	 (x-ref (cdr pat) parent active-nt nt-stack)
       (declare (ignore fwild optional-p))
       (setq firsts (dy-insert '$ firsts))
       (add-parent '$ parent)
       (values firsts t lasts lwild terms t vars)))

    ;; This operator is essentialy the same as the previous pair with
    ;; the exception that input must be consumed. fwild is t
    (&ui     
     (multiple-value-bind
	   (firsts fwild lasts lwild terms optional-p  vars)
	 (x-ref (cdr pat) parent active-nt nt-stack)
       (declare (ignore fwild))
       (setq firsts (dy-insert '$ firsts))
;	     optional-p t) ;;; *** change to reflect operator action.
       (add-parent '$ parent)
       (values firsts t lasts lwild terms optional-p 
	        vars)))

    ;; These are operators that perform tests without moving
    ;; the input pointer. As such they have no associated 
    ;; xref information in the first/last fields.
    (&n
;;------------------------ nuria-moisés -------------------------
;     (multiple-value-bind
;	   (firsts fwild lasts lwild terms optional-p vars)
;	 (x-ref (cdr pat) parent active-nt nt-stack)
;       (declare (ignore firsts fwild lasts lwild optional-p))
;       (add-parent '$ parent)
;       (values (list '$) t (list '$) t terms nil vars)))

;---------------------------------------------------------------
     (multiple-value-bind
	   (firsts fwild lasts lwild terms optional-p vars)
	 (x-ref (cdr pat) parent active-nt nt-stack)
       (declare (ignore firsts fwild lasts lwild
			optional-p))
       (values nil nil nil nil terms t vars)))

    (&s
     (multiple-value-bind
	   (firsts fwild lasts lwild terms optional-p vars)
	 (x-ref (cdr pat) parent active-nt nt-stack)
       (declare (ignore firsts fwild lasts lwild optional-p))
       (values nil nil nil nil terms t vars)))

    ;; As we consume input here, but we don't know what it is,
    ;; we set all of the first/last fields to be wild.
    (~ 
     (multiple-value-bind
	   (firsts fwild lasts lwild terms optional-p vars)
	 (x-ref (cdr pat) parent active-nt nt-stack)
       (declare (ignore firsts fwild lasts lwild optional-p))
       (add-parent '$ parent)
       (values (list '$) t (list '$) t terms nil vars)))

    ;; Since this is a simple list of terminals, the only fields of
    ;; interest are the firsts, lasts and terms.
    (&m (mapc (funl (term)
		(process-terminal term parent))
	      (cdr pat))
	(values (dy-sort (cdr pat)) nil (dy-sort (cdr pat)) nil
		(dy-sort (cdr pat)) nil nil))

    ;;; Intentamos incluir el operador &morph.
    (&morph
     (x-pat '(&m small smaller smallest) parent active-nt nt-stack))
    
    ;; Without access to the semantic category database, we can make
    ;; no predictions about this operator, and therefore treat it
    ;; as a wildcard.
    (&sc (add-parent '$ parent)
	 (values (list '$) t (list '$) t nil nil nil))

    ;; These operators are all optional, in that they don't need
    ;; to consume input to succeed.  We note that fact in the
    ;; optional-p field.
    ((? &o *)
     (multiple-value-bind
	   (firsts fwild lasts lwild terms optional-p vars)
	 (x-ref (cdr pat) parent active-nt nt-stack)
       (declare (ignore optional-p))
       (values firsts fwild lasts lwild terms t vars)))

    ;; Nothing special here, just pass on the values from the
    ;; cross-referencing of the subpattern.
    (+ 
     (multiple-value-bind
	   (firsts fwild lasts lwild terms optional-p vars)
	 (x-ref (cdr pat) parent active-nt nt-stack)
       (values firsts fwild lasts lwild terms optional-p vars)))

    ;; Here we loop across the pattern elements, gathering the
    ;; results from each and returning the union.
    ((! !!)
     (multiple-value-bind
	   (firsts fwild lasts lwild terms optional-p vars)
	 (x-ref (cadr pat) parent active-nt nt-stack)
       (dolist (p (cddr pat)
		  (values firsts fwild lasts lwild terms
			  optional-p vars))
	   (multiple-value-bind (f fw l lw te op v)
	       (x-ref p parent active-nt nt-stack)
	     (setq firsts (dy-merge f firsts)
		   fwild (or fw fwild)
		   lasts (dy-merge l lasts)
		   lwild (or lw lwild)
		   terms (dy-merge te terms)
		   optional-p (or optional-p op)
		   vars (dy-merge v vars))))))

    ;; This is the same as the above, except that the pattern
    ;; is optional only if all of the pattern elements are also
    ;; optional.
    (&c
     (multiple-value-bind
	   (firsts fwild lasts lwild terms optional-p vars)
	 (x-ref (cadr pat) parent active-nt nt-stack)
       (setq optional-p t)		 ; for the first cycle
       (dolist (p (cddr pat)
		  (values firsts fwild lasts lwild terms
			  optional-p vars))
	   (multiple-value-bind (f fw l lw te op v)
	       (x-ref p parent active-nt nt-stack)
	     (setq firsts (dy-merge f firsts)
		   fwild (or fw fwild)
		   lasts (dy-merge l lasts)
		   lwild (or lw lwild)
		   terms (dy-merge te terms)
		   optional-p (and optional-p op)
		   vars (dy-merge v vars))))))

    ;; variable reference is another operator which is difficult
    ;; to precompute.  Thus we opt for wildcard values.
    (= 
       (add-parent '$ parent)
      (values (list '$) t (list '$) t nil nil (cdr pat)))

    ;; variable assignment returns the result of the subpattern
    ;; plus the name of the variable.  We also add the variable
    ;; to the list of global variables (!!pat-vars) and set that
    ;; variable to have a global value of nil.
    (:=
     (multiple-value-bind
	   (firsts fwild lasts lwild terms optional-p vars)
	 (x-ref (cddr pat) parent active-nt nt-stack)
       (setq vars (dy-insert (cadr pat) vars)
	     !!pat-vars (dy-insert (cadr pat) !!pat-vars))
       (setf (symbol-value (cadr pat)) nil)
       (values firsts fwild lasts lwild terms optional-p vars)))

    ;; Asignacion de variable. No debe parsear ninguna entrada, con
    ;; lo que los unicos valores que nos interesan son wild y optional.
    ;; Nuria Ripoll. 26F.
    (<-
       (values nil t nil t nil t nil))


    ;; We skip the second argument to these operators and return
    ;; the values derived from cross-referencing the sub-pattern
    ;; argument.  If we have an &i without a pattern argument
    ;; we modify the return values to show wildcard behaviour.
    (&i
     (multiple-value-bind
	   (firsts fwild lasts lwild terms optional-p vars)
	 (x-ref (cddr pat) parent active-nt nt-stack)
       (if (null firsts)
	   (progn (setq fwild t lwild t optional-p t)
		  (add-parent '$ parent)))
       (values firsts fwild lasts lwild terms optional-p vars)))

    (^
     (multiple-value-bind
	   (firsts fwild lasts lwild terms optional-p vars)
	 (x-ref (cddr pat) parent active-nt nt-stack)
       (values firsts fwild lasts lwild terms optional-p vars)))

    ;; We treat this operator as a wildcard, also recording the
    ;; variable name arguments.
    (&a
     (add-parent '$ parent)
     (values nil t nil t nil t (list (cadr pat) (caddr pat))))

    
    ;; The otherwise clause prints a message that the
    ;; grammar is faulty.
    (t (if pat
	   (if (member (car pat) !!non-pattern-operators)
	       (let ((sym (get (car pat) :symbol)))
		 (add-parent sym parent)
		 (values (list sym) t (list sym) t nil nil nil))
	       (progn (smptrace 'x-pat1 pat)
		      (values nil nil nil nil nil nil nil)))))))

;;; x-ref
;;; the heart of the cross-referencer.  given a pattern, the immediate parent
;;; of the pattern, and a control stack, each pattern is analyzed to determine
;;; all of the terminals, firsts, and lasts of that pattern.  These are then
;;; returned to the calling routine.

;;; pat is a pattern
;;; parent is the current parent 
;;; active-nt is either a non-terminal or nil.  This variable is used to
;;;      control for left recursion.
;;; nt-stack is a stack of currently active non-terminals on the way down the 
;;;      first/last search tree.

(defun x-ref (pat parent active-nt nt-stack)
  (do ((pattern (cdr pat) (cdr pattern))
       (p (car pat) (car pattern))
       (firsts)(fwild)(lasts)(lwild)
       (terms)(vars)(tmp)
       (first-flag t))
      
      ;; Note that if x-ref is passed a nil pattern the values will all
      ;; be nil.
      ((null p)
       (values firsts fwild lasts lwild terms first-flag vars))

    ;; If we are looking for firsts, then there is a possibility of left
    ;; recursion.  The variable active-nt is a pointer to the nt-stack.
    ;; Everything before this point has the possibility of being left
    ;; recursive.  If we are not looking for firsts, then set pointer to
    ;; nil.
    (and active-nt
	 (not first-flag)
	 (setq active-nt nil))
    
    (cond

      ;; Are we looking at an operator?
      ((listp p)
       (multiple-value-bind (f fw l lw tm ff v)
	   (x-pat p parent active-nt nt-stack)
	 (if first-flag
	     (setq firsts (dy-merge f firsts)
		   fwild (or fw fwild)))
	 (if ff
	     (setq lasts (dy-merge l lasts)
		   lwild (or lw lwild))
	     (setq lasts (copy-list l)
		   lwild lw))
	 (setq terms (dy-merge tm terms)
	       first-flag (and first-flag ff)
	       vars (dy-merge v vars))))
      
      ;; Are we looking at a nonterminal?
      ((nontermp p)
       (ptrace "n")

       ;; It isn't defined
       (cond ((null (get-rule-hash p))
	      (setq !!not-defined
		    (dy-insert p !!not-defined))
	      (put-rule-hash p (make-nt :name p :pattern nil
					:parents (list parent)))
	      (if first-flag
			(setq first-flag nil)))

	     ;; It isn't defined, but we've seen it before.
	     ((and (get-rule-hash p)
		   (null (get-pattern p)))
	      (add-parent p parent)
	      (if first-flag
		  (setq first-flag nil)))

	     ;; Is it in the stack and is it still looking for firsts?
	     ;; left recursive!
	     ((member p (member active-nt (reverse nt-stack)))
	      (add-parent p parent)
	      (smformat 'x-ref1 p))

	     ;; Is the nonterminal defined and is it in the currently
	     ;; active stack?
	     ((and (setq tmp (get-pattern p))
		   (member p nt-stack))
	      (add-parent p parent))

	     ;; Has it been cross-referenced before?
	     ((and tmp (get-first p))
	      (add-parent p parent)
	      (if (get-opt p)
		  (setq lasts (dy-merge (get-last p) lasts)
			lwild (or (get-lwild p) lwild))
		  (setq lasts (copy-list (get-last p))
			lwild (get-lwild p)))

	      (if first-flag
		  (setq firsts (dy-merge (get-first p) firsts)
			fwild (or (get-fwild p) fwild)
			first-flag (get-opt p))))
	     
	     ;; Is it defined?
	     (tmp
	       (multiple-value-bind (f fw l lw tm ff v)
		   (x-ref tmp p (or active-nt p)
			  (cons p nt-stack))
		 (add-parent p parent)
		 (set-first p f)
		 (set-fwild p fw)
		 (set-last p l)
		 (set-lwild p lw)
		 (set-terminals p tm)
		 (set-opt p ff)
		 (set-variables p v)
		 (if first-flag
		     (setq firsts (dy-merge f firsts)
			   fwild (or fw fwild)))
		 (if ff
		     (setq lasts (dy-merge l lasts)
			   lwild (or lw lwild))
		     (setq lasts (copy-list l)
			   lwild lw))

		 (setq terms (dy-merge tm terms)
		       first-flag nil
		       !!used-nonterms
		       (dy-insert p !!used-nonterms))))))

      ;; Is the thing a wildcard?
      ((or (member p '($ $r $d $w))
	   (eql (get p :symbol) '$))
       (add-parent '$ parent)
       (if first-flag
	   (setq firsts (dy-insert '$ firsts)
		 fwild t
		 first-flag nil))
       (setq lasts (list '$)
	     lwild t))

      ;; Is it a number?
      ((or (numberp p) (eql (get p :symbol) '$n))
       (add-parent '$n parent)
       (if first-flag
	   (setq firsts (dy-insert '$n firsts)
		 first-flag nil))
       (setq lasts (list '$n)
	     lwild nil))
      
      ;; It must be a terminal
      (t (setq terms (dy-insert p terms))
	 (process-terminal p parent)
	 (if first-flag
	     (setq firsts (dy-insert p firsts)
		   first-flag nil))
	 (setq lasts (list p)
	       lwild nil)))))

(defun process-terminal (terminal parent)
  ;; If we are seeing this terminal for the first time
  ;; we need to create a structure to hold it, otherwise
  ;; just update the existing parents field.
  (if (get-terminal-hash terminal)
      (add-parent terminal parent)
      (progn
	(new-terminal-hash terminal :parents (list parent))
	;; We also add the terminal to a data structure used
	;; by the spelling correction routines.
	(setf (aref *dypar-terminal-array* (length (string terminal))) 
	      (dy-insert terminal
			 (aref *dypar-terminal-array*
			       (length (string terminal))))))))

;;; loadgra
;;; loadgra is the main function that is called to load a grammar. 
;;; multiple grammar files can be loaded at the same time and there
;;; is a check to see if any of these files have been loaded before.
;;; The following three functions are called to do the three primary
;;; operations needed for loading a grammar; loadgrammar (it's in ixload.l),
;;; to load the rules, cross-reference, to do the cross-referenceing, and
;;; setup-hash-table, to create the dictionary.
(defun loadgra (&rest files)
  (if (null !!files-loaded)
      (progn
	(new-terminal-hash '$)
	(new-terminal-hash '$n)))
  (dolist (file files)
    (let ((f file))
      (cond ((or (not (member f !!files-loaded))
		 (y-or-n-p "File " f " has already been loaded."
			   "Should I reload it? "))
	     (smptrace 'loadgra1 f)
	     (loadgrammar f)
	     (setq !!files-loaded (cons file !!files-loaded))))))
  (dolist (f files t)
    (cross-reference f)))

;;; erasegra
;;; erases the present grammars loaded, clearing all p-lists and the
;;; dictionary table.
(defun erasegra (&optional (*package* (find-package 'dypar)))
    (clrhash *dypar-structure-hash*)
    (clrhash *dypar-terminal-hash*)
    (setf *dypar-terminal-array*
	  (make-array 20 :element-type 'list :initial-element nil))

    (new-terminal-hash '$n)
    (new-terminal-hash '$)
;    (remprop '$n ':lwhere)
;    (remprop '$o ':lwhere)
;    (remprop '$n ':where)
;    (remprop '$o ':where)

    ;; remove all the rules from the file named symbols
    (dolist (f !!files-loaded)
	    (setf (new-nonterms f) nil)
	    (setf (new-pattrans f) nil)
	    (setf (new-recovers f) nil)
	    (setf (new-patrules f) nil))

    ;; nil the globals
    (setq !!terminals nil
	  !!patrules nil
	  !!recorules nil
	  !!pattrans nil
	  !!nonterms nil
	  !!firsts nil
	  !!lasts nil
	  !!pat-vars nil
	  !!used-nonterms nil
	  !!not-used-nts nil
	  !!not-defined nil
	  !!multiple-nts nil
	  !!files-loaded nil)
    ;; poner a NIL las variables de elipsis y anafora
    (setq *elipsis-rules* nil)
    (setq *anafora-rules* nil)

    (setsym 'rul 0)
    (setsym 'tra 0)
    (smptrace 'erasegra1))

;;; Show-gra displays general information on the currently loaded grammar(s)
(defun showgra ()
  (format t "~&Current Source Files: ~S~2&" !!files-loaded)
  (format t "RULES: ~S~&" (length !!patrules))
  (pprint !!patrules) (terpri) (terpri)
  (format t "NONTERMS: ~S~&" (length !!nonterms))
  (pprint !!nonterms) (terpri) (terpri)
  (format t "TRANSFORMATIONS: ~S~&" (length !!pattrans))
  (pprint !!pattrans) (terpri) (terpri)
  (format t "RECOVERY-RULES: ~S~&" (length !!recorules))
  (pprint !!recorules) (terpri) (terpri)
  (format t "TERMINALS: ~S~&" (length !!terminals))
  (pprint !!terminals) (terpri))


(defvar *xref-loaded* t)