;;; -*- 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 ?) ; == ! ; == anything that evaluates to a rewrite in EXTERNAL ; form ; ; (def-rule ) ; == any legal action ; ; (def-trans ) ; ; 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)