;******************************************************************************
; Patrick O'Connor - October, 1988
;    1. Added Bill Parker's semantic checks (6-9).
;    2. Updated to new parameterized environment
;    3. Replaced C. Szekely's semantic check #1 and #2 with Qixiong's.
;    4. Added Qixiong's semantic check (#10 here).
;
; C. Szekely - April, 1988
;    1. put all semantic checkers for parameterized grammar in this file
;    2. modified error messages in each semantic checker to be more descriptive
;    3. modified each semantic check to return the number of errors found
;    4. wrote method 'par-semantic-checks' to call each semantic check
;       and print the number of errors found
;
; This file contains the code for the parameterized semantic checker.  It 
; checks for 9 semantic conditions which all parameterized grammars given
; as input to the demeter system must uphold.  These tests are:
; 
;    1) Every class (whether parameterized or not) must be defined
;       exactly once. The only exceptions are the classes specified
;       by **class-terminals**.
; 
;    2) #formal parameters = #actual parameters
; 
;    3) In an alternation class with implied inheritance (*common*) the 
;       alternatives must be defined by constructions or by alternations
;       that will eventually be defined by constructions.
; 
;    4) An instance of a parameterized class is only allowed to inherit from
;       a neutral or a construction production.
;
;    5) boundedness.
;
;    6) An instance of a parameterized class must be labelled 
;       (in neutral and construction and in alternation productions
;       after *common*) if it contains a formal parameter. Example:
;          A(S) = S. 
;          B(S,T) = List(S) CommaList(T).
;       are both disallowed. If the label is missing, print a warning.
;
;    7) Check that the two instances on the right hand-side of a 
;       repetition production are identical. For example,
;          S ~ G(Ident) {G(String)}. 
;          T ~ A {B}.
;       are illegal.
;
;    8) Actual parameters for formal class parameters must be 
;       non-parameterized classes.
;
;    9) Check that the names of instance variables are unique in a given
;       construction or neutral production.
;
;   10) Parameterized-Common: If a parameterized class is defined
;       by an alternation production which uses *common* then all the
;       alternatives have to use all the formal parameters.  An error
;       message is printed for every alternation production that violates
;       this rule.
;******************************************************************************

; Main routine for parameterized semantic checks 
; To run type:  (send *head* ':par-semantic-checks)
; The total number of errors is returned and global *semantic-errors* also
; contains this number.

;
; grammar = < rules > rule-list
;
(defmethod (Grammar :par-semantic-checks) (&optional filename)
   (if filename (setq stream (outfile filename)) (setq stream t))
;   (setq *current-head* self)
   (setq *semantic-errors*
      (+ (send self ':check-unique)               ;TEST #1
         (send self ':match-parameters)           ;TEST #2
         (send self ':ch37 stream)                ;TEST #3
         (send self ':gcheck)                     ;TEST #4
;         (send self ':check-regularity)          ;TEST #5
         (send self ':label-instance-formal)      ;TEST #6
	 (send self ':repetition-identical)       ;TEST #7
	 (send self ':non-par-classes-as-actual)  ;TEST #8
	 (send self ':unique-instance-var-names)  ;TEST #9
	 (send self ':parameterized-common)       ;TEST #10
)
   )
   (format t "~%~a Semantic Errors were found.~%~%" *semantic-errors*)
   *semantic-errors*
)


;******************************************************************************
; COM 3351/Winterint 1988  N.S.D. Smith
;
; This file contains a corrected version of 'regularity.l', written
; by Ron Greene and modified by Gar-Lin Lee.  I have further modified
; the file to:
;
;       1) remove extraneous methods not needed after Gar-Lin Lee's
;          modifications, and
;
;       2) solve the 'aliasing' problem mentioned by Gar-Lin below; that
;          is, the check-regularity methods can now recognize a change
;          in formal parameter names during the boundedness check.
;
;          All changes are marked by ;NS comments
;
; 4/88 - CMS: Updated the methods to reflect the new version of the 
;             parameterized grammar. (i.e., basicinstanceparassoccommalist 
;             is now basicinstance-parassoc-commalist, etc.).
;



;************************************************************************
;
;  COM 3351           Assignment 7            Ron Greene
;
;      The methods given below implement a check for regularity in
; parameterized data dictionaries.  The program consists of two
; main parts --- the :find-recursives and related methods, and the
; :check-regularity and related methods.
;
;      The :find-recursives group loops through the rules of the
; grammar, setting the "recursive" property of each rule name to t
; or nil, depending on whether the rule is recursively used or not.
;
;      The :check-regularity group then examines the actual parameters
; of every use of a recursive class T to verify that each actual parameter
; is either
;
;          1) a formal parameter of T,
;          2) an instance of some parameterized class which does not
;             have a formal parameter of T as actual parameter,
;      or  3) a class.
;
;GL   the "recursive" property is not a property of a rule, it's the 
;GL   property of an instantiation of the class defined by the rule.
;GL   I've changed the program to combine the find-recursives and check-
;GL   regularity stages.  Whenever a recursive use of a parameterized class
;GL   is found, the check-regularity method is invoked.
;GL   Because of this change, some of the :check-regularity methods may no
;GL   longer be needed, but they have not been removed yet.
;
;GL   The program only handle the case where all parameters have the same name.
;GL   It cannot detect the following violation:
;GL     A(X) = B(X).
;GL     B(Y) = A(C(Y)).
;
;      The regularity check call is of the following form:
;
;              (send *head* ':check-regularity)
;
; where *head* is the object that results from parsing the parameterized
; data dictionary.
;
;*************************************************************************


;*************************************************************************
;          :check-regularity and :check-regularity-aux methods
;*************************************************************************

;
; grammar = < rules > rule-list
;
; The :find-recursives call will set to t the "recursive" property of the
; name of each rule which is used recursively in the grammar
; 
(defmethod (grammar :check-regularity) ()
    (setq *head* self)         ; CMS
    (setq *regularity-errs* 0) ; CMS - init error count.
    (send self ':find-recursives)
;Gl  combine the two stages
;    (send rules ':check-regularity)
    *regularity-errs* ; CMS - returns number of errors found
)


;
; instance = <instancename> ident [ "(" <actualparameters> basicinstance-parassoc-commalist ")" ] 
;
; labeledinstance and optionalinstance inherit from instance
;
(defmethod (instance :check-regularity-aux) (formalparams)
   ;(if (and actualparameters (get (send instancename ':val) 'recursive)))
   (if actualparameters
       (if (not (send actualparameters ':check-regularity-aux formalparams))then
;NS added the newlines in the formats below to improve runtime readability
         ;CMS - Changed error message to be consistent w/ other semantic checks.
         (format stream "~%Semantic Error: The use of '~A' in ~%                " 
            (send instancename ':val))
	 (send-self ':pp stream)
	 (format stream "~%                violates regularity.~%~%")
	 (setq *regularity-errs* (+ 1 *regularity-errs*))) ; CMS - count errors.
  ) 
)

;
; inheritinstance = "*inherit*" < inheritsfrom > basicinstance-commalist [ "*override*" < overrides > label-commalist-labeledinstance-nonemptylist "*end*" ] 
;
(defmethod (inheritinstance :check-regularity-aux) (formalparams)
    (send inheritsfrom ':check-regularity-aux formalparams)
)
;
; basicinstance-commalist ~ basicinstance { "," basicinstance } 
;
(defmethod (basicinstance-commalist :check-regularity-aux) (formalparams)
    (loop for each-basicinstance in child do
          (send each-basicinstance ':check-regularity-aux formalparams))
)

;
; basicinstance-parassoc-commalist ~ basicinstance-parassoc { "," basicinstance-parassoc } 
;
(defmethod (basicinstance-parassoc-commalist :check-regularity-aux) (formalparams)
   (let ((formals formalparams))
      (loop for each-basicinstance-parassoc in child
	    for parameter = (car formals)
            for check = (send each-basicinstance-parassoc
				 ':check-regularity-aux formalparams parameter)
         when (not check) do (return nil)
         else do (setq formals (cdr formals))
         finally (return t)))
)

; basicinstance-parassoc = [ "=>" <formalparameter> ident ] <actualorformalparameter> basicinstance
;
(defmethod (basicinstance-parassoc :check-regularity-aux) (formalparams parameter)
    (let ((formal (if formalparameter formalparameter parameter)))
       (send actualorformalparameter ':check-regularity-aux-aux formalparams formal))
)

;
(defmethod (terminal :check-regularity-aux) (rulename)
   nil)

;
(defmethod (ppindent :check-regularity-aux) (rulename)
   nil)

;
(defmethod (ppunindent :check-regularity-aux) (rulename)
   nil)

;
(defmethod (ppskip :check-regularity-aux) (rulename)
   nil)

;
(defmethod (ppspace :check-regularity-aux) (rulename)
   nil)

;
; instance = <instancename> ident [ "(" <actualparameters> basicinstance-parassoc-commalist ")" ] 
;
; This is where the regularity requirements are checked
;
(defmethod (instance :check-regularity-aux-aux) (formalparams formal)
   (or (null actualparameters)
       (eql (send instancename ':val) formal)
       (null (intersection formalparams
			   (send actualparameters ':get-paramlist))))
)


;**************************************************************************
;        :get-paramlist methods - build lists of the names of formal
;                                 and actual parameters
;**************************************************************************

;
; basicinstance-parassoc-commalist ~ basicinstance-parassoc { "," basicinstance-parassoc }  
;
(defmethod (basicinstance-parassoc-commalist :get-paramlist) ()
   (loop for each-basicinstance-parassoc in child
      collect (send each-basicinstance-parassoc ':get-paramlist))
)

;
; basicinstance-parassoc = [ "=>" <formalparameter> ident ] <actualorformalparameter> basicinstance
;
(defmethod (basicinstance-parassoc :get-paramlist) ()
   (send actualorformalparameter ':get-paramlist)
)

;
; basicinstance = < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (basicinstance :get-paramlist) ()
   (send instancename ':val)
)

;
; formalparameters = "(" <formals> formalparameter-commalist ")"
;
(defmethod (formalparameters :get-paramlist) ()
   (send formals ':get-paramlist)
)

;
; formalparameter-commalist ~ formalparameter { "," formalparameter }
;
(defmethod (formalparameter-commalist :get-paramlist) ()
   (loop for each-formalparameter in child
      collect (send each-formalparameter ':get-paramlist))
)

;
; formalparameter = < parametername > ident [ ":" < noofargs > number ] 
;
(defmethod (formalparameter :get-paramlist) ()
   (send parametername ':val)
)


;**************************************************************************
;          :find-recursives and :find-recursives-aux methods
;
; These methods loop through the list of rules of the grammar.  For each
; rule, the symbols on the right side are checked for recursive use.  In
; turn, the symbols on the right side of the rule definitions of these symbols
; are checked, and so on.  A global variable *checked* is used to keep
; track of rules that have already been searched to prevent infinite 
; recursion of the methods.
;
;**************************************************************************

;
; grammar = <rules> rule-list 
;
(defmethod (grammar :find-recursives) ()
    (send rules ':find-recursives)
)

;
; rule-list ~ { rule }
;
; Sets the "recursive" property value of the name of each rule to t or
; nil, according to whether the rule is recursive or not.
;
(defmethod (rule-list :find-recursives) ()
    (loop for each-rule in child
          for recursive = (send each-rule ':find-recursives)
          for name = (send each-rule ':valofname)
       when recursive do (setf (get name 'recursive) t)
       else do (setf (get name 'recursive) nil))
)

;
; rule = <rulename> ident [ formalparameters ] body "." 
;
; Initializes the global list *checked* as each rule is investigated
; for recursive use
;
(defmethod (rule :find-recursives) ()
   (setq *checked* (cons (send rulename ':val) **class-terminals**))
   (if formalparameters
       (send body ':find-recursives rulename 
	     (send formalparameters ':get-paramlist)))
)

;
; constructbodycore = <elements> anyinstance-list 
;
; constructbody, instbody, and uninstbody inherit from constructbodycore
;
(defmethod (constructbodycore :find-recursives) (rulename formalparm)
    (send elements ':find-recursives rulename formalparm)
)

;
; repetitbody = "~" <first> stringorpp-list [ <nonempty> basicinstance ] <repeated> repeatedinstance <second> stringorpp-list 
;
(defmethod (repetitbody :find-recursives) (rulename formalparm)
    (send repeated ':find-recursives rulename formalparm)
)

;
; alternatbody = ":" <alternatives> optstarredbasicinstance-barlist [ "*common*" <common> anyinstance-list ] 
;
(defmethod (alternatbody :find-recursives) (rulename formalparm)
    (or (send alternatives ':find-recursives rulename formalparm)
        (if common
            (send  common ':find-recursives rulename formalparm)))
)

;
; repeatedinstance = "{" <left> stringorpp-list <inner> basicinstance <right> stringorpp-list
;
;Old definition: repeatedinstance = "{" <repeated> instance-sandwiched "}" 
;
(defmethod (repeatedinstance :find-recursives) (rulename formalparm)
    (send inner  ':find-recursives rulename formalparm)
    ; CMS - changed for new parameterized grammar.
    ; (send repeated ':find-recursives rulename formalparm)
)

;
; optstarredbasicinstance-barlist ~ optstarredbasicinstance { "|" optstarredbasicinstance } 
;
(defmethod (optstarredbasicinstance-barlist :find-recursives) (rulename formalparm)
   (loop for each-optstarredbasicinstance in child do
     (send each-optstarredbasicinstance ':find-recursives rulename formalparm))
)

;
; anyinstance-list ~ { anyinstance } 
;
(defmethod (anyinstance-list :find-recursives) (rulename formalparm)
    (loop for each-anyinstance in child do
	  (print '(wow1))
       (send each-anyinstance ':find-recursives rulename formalparm)
	  (print '(wow2)))
)

;
; Old definition: instance = <instancename> ident [ "(" <actualparameters> basicinstance-parassoc-commalist ")" ] 
; labeledinstance and optionalinstance inherit from instance
;
; CMS - added description of definition from new parameterized grammar:
;
; instance : label-commalist-optlabeledinstance | optionalinstance
;  *common*
;    <instanceName> QualIdent 
;    [<actualParameters> basicinstance-parassoc-commalist].
; label-commalist-optlabeledinstance and optionalinstance inherit from instance
;
(defmethod (instance :find-recursives) (rulename formalparm)
   (if (eql (send instancename ':val) (send rulename ':val))
       (send-self ':check-regularity-aux formalparm))
   (send instancename ':find-recursives rulename formalparm)
   (if actualparameters
       (send actualparameters ':find-recursives rulename formalparm))
)

;
; basicinstance-parassoc-commalist ~ basicinstance-parassoc { "," basicinstance-parassoc } 
;
(defmethod (basicinstance-parassoc-commalist :find-recursives) (rulename formalparm)
    (loop for each-basicinstance-parassoc in child do
       (send each-basicinstance-parassoc ':find-recursives rulename formalparm))
)

;
; basicinstance-parassoc = [ "=>" <formalparameter> ident ] <actualorformalparameter> basicinstance
;
(defmethod (basicinstance-parassoc :find-recursives) (rulename formalparm)
    (send actualorformalparameter ':find-recursives rulename formalparm)
)

;
(defmethod (terminal :find-recursives) (rulename formalparm)
   nil)

;
(defmethod (ppindent :find-recursives) (rulename formalparm)
   nil)

;
(defmethod (ppunindent :find-recursives) (rulename formalparm)
   nil)

;
(defmethod (ppskip :find-recursives) (rulename formalparm)
   nil)

;
(defmethod (ppspace :find-recursives) (rulename formalparm)
   nil)


;
; recursively check the right side of the rule specified by the ident
; if it has not already been checked
;
(defmethod (ident :find-recursives) (rulename formalparm)
   (if (not (member val *checked*))
       (progn (setq *checked* (cons val *checked*))
              (send *head* ':find-recursives-aux val rulename formalparm))
       nil
   )
)

;
; grammar = <rules> rule-list 
;
(defmethod (grammar :find-recursives-aux) (name rulename formalparm)
    (send rules ':find-recursives-aux name rulename formalparm)
)

;
; rule-list ~ { rule }
;
(defmethod (rule-list :find-recursives-aux) (name rulename formalparm)
   (loop for each-rule in child
      when (send each-rule ':match-rule? name)
	   do (return (send each-rule ':find-recursives-aux rulename formalparm)))
)

;
; rule = <rulename> ident [ formalparameters ] body "." 
;
;
;NS changes start
;   The only change made to the operation of check-regularity was to
;   add the formal parameter list for the rule being recursively
;   searched at this point to the 'formalparm' list.
;
(defmethod (rule :find-recursives-aux) (originalrulename formalparm)
;NS new code starts 
   (let ((newformals (if formalparameters
			then (append (send formalparameters ':get-paramlist)
				     formalparm)
			else formalparm
		      )))
    	(send body ':find-recursives originalrulename newformals)
     )
;NS new code ends
;NS old code starts
;       (send body ':find-recursives originalrulename formalparm)
;NS old code ends
)
;NS changes end
;
;
;
; inheritinstance = "*inherit*" < inheritsfrom > basicinstance-commalist [ "*override*" < overrides > label-commalist-labeledinstance-nonemptylist "*end*" ] 
;
(defmethod (inheritinstance :find-recursives) (rulename formalparm)
    nil
)


;********************************************************************
;         miscellaneous methods
;********************************************************************

;
; rule = <rulename> ident [ formalparameters ] body "." 
;
(defmethod (rule :valofname) ()
   (send rulename ':val)
)

;
; rule = <rulename> ident [ formalparameters ] body "." 
;
(defmethod (rule :match-rule?) (name)
   (eql name (send rulename ':val))
)


;*****************************************************************************
; Patrick O'Connor.  March 21, 1988.
;
;*****************************************************************************
;
; This file implements the semantic check 3.7.
;
;*******************************************************

;*******************************************************
; 
; ALL methods
;       is defined for rulelist and optstarredbasicinstance-barlist.
;        It is used to send to each rule, the message indicated by 
;        its argument, method-to-send.
;
;*******************************************************
;
; rule-list ~ { rule } 
;

(defmethod (rule-list :all2) (method-to-send stream)
  (loop for each-rule in child do 
	(send each-rule method-to-send stream))
) 

;
; optstarredbasicinstance-barlist ~ optstarredbasicinstance { "|" optstarredbasicinstance } 
;
(defmethod (optstarredbasicinstance-barlist :all2) (method-to-send rule-name stream)
  (loop for each-optstarredbasicinstance in child do
	(send each-optstarredbasicinstance method-to-send rule-name stream)))


;***************************************************
;
; pre-ch37 methods
;       auxiliary pre-processing methods used
;       to set up a list of rules that have
;       been defined as construction or neutral
;       productions.
;
;***************************************************

;
; rule = < rulename > ident [ formalparameters ] body "." 
;

(defmethod (rule :pre-ch37) (stream)
  (send body ':pre-ch37 (send rulename ':val) stream))

;
; repetitbody = "~" < first > stringorpp-list [ < nonempty > basicinstance ] < repeated > repeatedinstance < second > stringorpp-list 
;
(defmethod (repetitbody :pre-ch37) (rule-name stream)
  nil)

;
; alternatbody = ":" < alternatives > optstarredbasicinstance-barlist [ "*common*" < common > anyinstance-list ] 
;
(defmethod (alternatbody :pre-ch37) (rule-name stream)
  (push (cons rule-name alternatives) *alternat-rules*))

;
; constructbody = "=" < elements > anyinstance-list 
;
(defmethod (constructbody :pre-ch37) (rule-name stream)
  (push rule-name *const-rules*))

;
; instbody = "!!" < elements > anyinstance-list 
;
(defmethod (instbody :pre-ch37) (rule-name stream)
  nil)

;
; uninstbody = "!" < elements > anyinstance-list 
;
(defmethod (uninstbody :pre-ch37) (rule-name stream)
  nil)

;***************************************************
;
; ch37 methods
;      These implement semantic check 3.7. This check
;      makes sure that in an alternation class with
;      implied inheritance (*common*) the alternatives
;      are defined by constructions or by alternations
;      that eventually will all be defined by
;      constructions.
;
;***************************************************

;
; grammar = < rules > rule-list 
;
(defmethod (grammar :ch37) (stream)
  (setq *const-rules* '(string number ident)) ;Rules that are constructions
  (setq *alternat-rules* nil)     ;Rules that are alternations
  (setq *common-errs* 0) ; CMS
  (send rules ':all2 ':pre-ch37 stream)
  (send rules ':all2 ':ch37 stream)
  *common-errs* ; CMS - returns number of errors found
)

;
; rule = < rulename > ident [ formalparameters ] body "." 
;
(defmethod (rule :ch37) (stream)
  (send body ':ch37 (send rulename ':val) stream))

;
; alternatbody = ":" < alternatives > optstarredbasicinstance-barlist [ "*common*" < common > anyinstance-list ] 
;
(defmethod (alternatbody :ch37) (rule-name stream)
  (if common
      (send alternatives ':all2 ':ch37 rule-name stream)
      t))

;
; The rest of the body choices are all true.
;
(defmethod (construction :ch37) (rule-name stream)
  t)

;
; basicinstance = < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (basicinstance :ch37) (rule-name stream)
  (if (member (send instancename ':val) *const-rules*)
      t
      (let ((temp (assoc (send instancename ':val) *alternat-rules*)))
	(if temp
	    (send (cdr temp) ':all2 ':ch37 (car temp) stream)
	    (progn
	      ;CMS - Changed error message to be consistent with others.
	      (format stream "~%Semantic Error: The use of *common* with class '~a'"
		         (send instancename ':val))
              (format stream "~%                in the definition of class '~a'~%"
                 rule-name)
	      (format stream "                is illegal since it is not defined")
	      (format stream " by construction~%                or an alternation")
	      (format stream " leading to construction.~%~%")
              (setq *common-errs* (+ 1 *common-errs*)) ; CMS - to count errors.
            ))))
)

;
; starredinstance = "*" < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (starredinstance :ch37) (rule-name stream)
  (if (member (send instancename ':val) *const-rules*)
      t
      (let ((temp (assoc (send instancename ':val) *alternat-rules*)))
	(if temp
	    (send (cdr temp) ':all2 ':ch37 (car temp) stream)
	    (progn
  	      ;CMS - Changed error message to be consistent with others.
	      (format stream "~%Semantic Error: The use of *common* with class '~a'"
		         (send instancename ':val))
              (format stream "~%                in the definition of class '~a'~%"
                 rule-name)
	      (format stream "                is illegal since it is not defined")
	      (format stream " by construction~%                or an alternation")
	      (format stream " leading to construction.~%~%")
              (setq *common-errs* (+ 1 *common-errs*)) ; CMS - to count errors.
            ))))
)



;*****************************************************************************
; Donna J. King
; Parameterized Data Dictionary Assignment
; Update of GCHECK methods from "sem-ch-hammond.l"
; March 23, 1988
;************************************************************************ 
; 
; ALL method 
;       is defined for rule-list only. It is used to  
;       send to each rule, the message indicated by 
;       its arguement, method-to-send.
;
; rule-list ~ { rule } 
;

(defmethod (rule-list :all) (method-to-send)
    (loop for each-rule in child do 
	   (send each-rule method-to-send))) 
;
;************************************************************************ 
;
; GCHECK methods
;         used to check that the geneology of the data
;         dictionary is defined properly, i.e. inheritance is
;         allowed only from construction and neutral productions.
; DK ---  Formal parameters are passed so that they may be ignored
;         along with the constructions and repetitions when checking
;         inheritance.
;
;************************************************************************ 
;
; grammar = < rules > rule-list 
;
(defmethod (grammar :gcheck) ()
   (setq *inheriting-instance* nil
         *const-or-neut-rules* nil)
   (setq *inherit-errs* 0) ; CMS
   (send rules ':all ':pre-gcheck)
   (send rules ':all ':gcheck)
   *inherit-errs* ; CMS - returns number of errors found
)

;
; rule = <rulename> ident [ formalparameters ] body "." 
;
(defmethod (rule :gcheck) ()
   (send body ':gcheck (send ruleName ':val)
		       (if formalParameters
		          then (send formalParameters ':make-list))))


;
; formalparameters = "(" < formals > formalparameter-commalist ")" .
;
(defmethod (formalParameters :make-list) ()
   (send-self ':make-list2 (send formals ':child)))

(defmethod (formalParameters :make-list2) (children)
   (loop for f in children collect
     (send f ':get-val)))

(defmethod (formalParameter :get-val) ()
  (send parameterName ':val))


;
; constructbody = "=" < elements > anyinstance-list 
;
(defmethod (constructbody :gcheck) (name-of-rule formalParms)
   (send elements ':gcheck name-of-rule formalParms))


;
; repetitbody = "~" < first > stringorpp-list [ < nonempty > basicinstance ]
;      < repeated > repeatedinstance < second > stringorpp-list 
;
(defmethod (repetitbody :gcheck) (name-of-rule formalParms)
          nil)


;
; alternatbody = ":" < alternatives > optstarredbasicinstance-barlist [ "*common*" < common > anyinstance-list ] 
;
(defmethod (alternatbody :gcheck) (name-of-rule formalParms)
   (send alternatives ':gcheck name-of-rule formalParms)
   (if common then
      (send  common ':gcheck name-of-rule formalParms)))


;
; instbody = "!!" < elements > anyinstance-list 
;
(defmethod (instbody :gcheck) (name-of-rule formalParms)
   (send elements ':gcheck name-of-rule formalParms))


;
; inheritinstance = "*inherit*" < inheritsfrom > basicinstance-commalist [ "*override*" < overrides > label-commalist-labeledinstance-nonemptylist "*end*" ] 
;
(defmethod (inheritinstance :gcheck) (name-of-rule formalParms)
   (setq *inheriting-instance* t)
   (send inheritsfrom ':gcheck name-of-rule formalParms)
   (if overrides then
     (send overrides ':gcheck name-of-rule formalParms)) 
   (setq *inheriting-instance* nil)) 


;
; instance = label-commalist-optlabeledinstance | optional-instance.
;
;
; basicinstance = < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (instance :gcheck) (name-of-rule formalParms)
   (if *inheriting-instance* 
     then
       (setq temp (send instancename ':val))
       (if (not (member temp (append *const-or-neut-rules* formalParms))) then
         ; CMS - Changed error message to be consistent with others.
         (format stream "~%Semantic Error: Illegal inheritance from class '~a'"
		           temp)
	 (format stream "~%                in definition of '~a'.~%"
		   name-of-rule)
	 (format stream "                An instance of a parameterized class ")
	 (format stream "can only inherit~%                from a neutral or a ")
	 (format stream "construction production.~%~%")
	 (setq *inherit-errs* (+ 1 *inherit-errs*)) ; CMS - to count errors.
       ))
)


;
; anyinstance-list ~ { anyinstance }. 
; label-commalist  ~ label { "," label }.
; instancebarlist  ~ instance { "|" instance }. 
; basicinstance-commalist ~ basicinstance { "," basicinstance }. 
;

(defmethod (repetition :gcheck) (name-of-rule formalParms)
   (send-self ':gcheck-children child))


(defmethod (repetition :gcheck-children) (children)
   (loop for each-instance in children do 
        (send each-instance ':gcheck name-of-rule formalParms)))


(defmethod (string :gcheck) (name-of-rule formalParms) nil)

(defmethod (ppcommands :gcheck) (name-of-rule formalParms) nil)


;
;***************************************************
;
; PRE-GCHECK methods
;       auxiliary pre-processing methods used
;       to set up a list of rules that have
;       been defined as construction or neutral
;       productions.
;
;***************************************************

;
; rule = < rulename > ident [ formalparameters ] body "." 
;
(defmethod (rule :pre-gcheck) ()
   (if (send body ':pre-gcheck) 
       (setq *const-or-neut-rules* 
           (cons (send rulename ':val)
	         *const-or-neut-rules*))))   

(defmethod (constructbody :pre-gcheck) () t)

(defmethod (instbody :pre-gcheck) () t)

(defmethod (repetitbody :pre-gcheck) () nil)

(defmethod (alternatbody :pre-gcheck) () nil)


;*****************************************************************************
; Qixiong Bian
;
; COM 3205 Software Design and Development
;
; Project 3
; Subtask #7
; 
; The following semantic checking program is modified to have a better error
; documentation and to adopt the new parameterized class dictionary.
;
; Cathryn Szekely
;
; COM3351 Principles of Programming Languages  Winter 1988
;
; Assignment #8 - semantic checks: a) each class definition is uniquely defined
;				   b) #formal parameters = #actual parameters
;
; The method check-unique returns t if each class is defined exacly once,
; nil otherwise.  An error message is printed for every multiple definition,
; and for every use of a class that is never defined (with the exception of
; the classes specified in the global list **class-terminals**).  Calling
; sequence is as follows:
;
; (send *head* ':check-unique)
;
; The method match-parameters returns t if the number of formal parameters 
; matches the number of actual parameters, nil otherwise. It prints an error
; message when the number of parameters do not match. All class definitions are
; assumed to be unique.  Calling sequence is as follows:
;
; (send *head* ':match-parameters)
;******************************************************************************



;******************************************************************************
; check-unique methods
;
; The class names on the lhs and the instance names on the rhs are collected 
; in two separate lists, then compared.  If a class name shows up twice on the
; lhs, it is a multiple definition, and if there is a class name on the rhs
; that did not show up on the lhs, it is an undefined class.
;******************************************************************************

(defmethod (repetition :check-unique) (&optional formals)
   (loop for each-element in child do 
      (send each-element ':check-unique formals)))

(defmethod (construction :check-unique) (&optional formals)
   (loop for each-element in (send self ':child) do 
      (if each-element (send each-element ':check-unique formals))))

(defmethod (terminal :check-unique) (&optional formals) nil)

; grammar = < rules > rule-list *l
;
(defmethod (grammar :check-unique) ()
  (setq *instancenames* nil) 
  (setq *rulenames* nil)
  (setq *unique-errors* 0)
  (send rules ':check-unique)
  (loop for each-name in *instancenames* unless 
    (or (member each-name *rulenames*)
        (member each-name **class-terminals**)) do
      (format stream 
        "~%~%Semantic Error: Class '~a' is used on rhs, but is not defined.~%~%"
	each-name)
      (setq *unique-errors* (+ 1 *unique-errors*))
  )
  *unique-errors*
)

; rule = *l < rulename > ident [ formalparameters ] body "." 
;
(defmethod (rule :check-unique) (f)
   (let ((rule-name (send rulename ':val)) (formals nil))
      (if (member rule-name *rulenames*) then
        (format stream "~%~%Semantic Error: Multiple definition of class '~a'." 
	          rule-name)
        (format stream "~%One of the definitions is:")
	(send self ':pp stream)
        (setq *unique-errors* (+ 1 *unique-errors*))
      else
        (setq *rulenames* (cons rule-name *rulenames*)))
      (if formalparameters
         (setq formals (send  formalparameters ':get-formals)))
      (send body ':check-unique formals)
   )
)

; basicinstance = < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] .
;
(defmethod (basicinstance :check-unique) (formals)
   (let ((formal nil) (name (send instancename ':get-name)))
      (if (member name formals) then (setq formal t))
      (if actualparameters then
	 (if formal then
	    (format stream "~%~%Semantic Error: formal parameter '~a'" name)
	    (format stream "~%                cannot have the same name as")
            (format stream "~%                parameterized class '~a'." 
	       name)
            (setq *unique-errors* (+ 1 *unique-errors*))
         else (send  actualparameters ':check-unique formals))
      )
      (if (and (not formal) (not (member name *instancenames*)))
         (setq *instancenames* (cons name *instancenames*)))
   )
)
; starredinstance = "*" < instancename> qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] .
;
(defmethod (starredinstance :check-unique) (formals)
   (let ((formal nil) (name (send instancename ':get-name)))
      (if (member name formals) then (setq formal t))
      (if actualparameters then
	 (if formal then
	    (format stream "~%~%Semantic Error: formal parameter '~a'" name)
	    (format stream "~%                cannot have the same name as")
	    (format stream "~%                parameterized class '~a'."
	       name)
            (setq *unique-errors* (+ 1 *unique-errors*))
         else (send  actualparameters ':check-unique formals))
      )
      (if (and (not formal) (not (member name *instancenames*)))
	 (setq *instancenames* (cons name *instancenames*)))
   )
)

;******************************************************************************
; get-formals methods
;
; The names of the formal parameters for a given rule are collected and
; returned in a list.
;******************************************************************************

; formalparameters = "(" , < formals > formalparameter-commalist ")" .
;
(defmethod (formalparameters :get-formals) ()
   (send formals ':get-formals))

; formalparameter-commalist ~ formalparameter { "," formalparameter } .
;
(defmethod (formalparameter-commalist :get-formals) ()
   (loop for each-formalparameter in child collect
      (send each-formalparameter ':get-name))
)

; formalparameter = < parametername > ident [ ":" < noofargs > number ] 
;
(defmethod (formalparameter :get-name) ()
   (send parametername ':val))



;******************************************************************************
; match-parameters methods
;
; The object hierarchy is first traversed to set the 'num-of-formals property
; of each rule.  Then it is traversed again to check for non-matching number of
; parameters by comparing number of actual parameters with num-of-formals for
; each object on the rhs.
;******************************************************************************

(defmethod (repetition :match-parameters) (&optional formals)
   (loop for each-element in child do 
      (send each-element ':match-parameters formals)))

(defmethod (construction :match-parameters) (&optional formals)
   (loop for each-element in (send self ':child) do 
      (if each-element (send each-element ':match-parameters formals))))

(defmethod (terminal :match-parameters) (&optional formals) nil)

; grammar = < rules > rule-list 
;
(defmethod (grammar :match-parameters) ()
   (setq *match-errors* 0) 
   (send rules ':count-formals)
   (send rules ':match-parameters)
   *match-errors*
)

; rule = < rulename > ident [ formalparameters ] body "." 
;
(defmethod (rule :match-parameters) (f)
   (setq *rule-error* nil)
   (let ((formals nil))
      (if formalparameters
         (setq formals (send  formalparameters ':get-formals)))
      (send body ':match-parameters formals)
   )
   (if *rule-error* then
      (format stream "~%~%The above error(s) occurred in the rule:")
      (send self ':pp stream))
)

; basicinstance-parassoc-commalist ~ basicinstance-parassoc { "," basicinstance-parassoc } 
;
(defmethod (basicinstance-parassoc-commalist :match-parameters) (formals)
   (loop for each-basicinstance-parassoc in child do
      (send each-basicinstance-parassoc ':match-parameters formals))
   (length (send self ':child))
)
   
; basicinstance = < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (basicinstance :match-parameters) (formals)
  (let* ((num-actuals 0) (name (send instancename ':get-name))
	 (num-formals (get name 'num-of-formals)) (formal nil))
     (if actualparameters then
       (setq num-actuals (send actualparameters ':match-parameters formals))
     else (if (member name formals) (setq formal t)))
     (if (not num-formals) (setq num-formals 0))
     (if (and (not formal) (not (eql num-actuals num-formals))) then
       (format stream "~%~%Semantic Error: Class '~a' expects ~a formal parameter(s)" 
	         name num-formals)
       (format stream "~%                but got ~a actual parameter(s)."
                 num-actuals)
       (setq *match-errors* (+ 1 *match-errors*))
       (setq *rule-error* t)
     ) 
  )
)

; starredinstance = "*" < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] .
;
(defmethod (starredinstance :match-parameters) (formals)
   (let* ((num-actuals 0) (name (send instancename ':get-name))
	  (num-formals (get name 'num-of-formals)) (formal nil))
      (if actualparameters then
	(setq num-actuals (send actualparameters ':match-parameters formals))
      else (if (member name formals) (setq formal t)))
      (if (not num-formals) (setq num-formals 0))
      (if (and (not formal) (not (eql num-actuals num-formals))) then
	(format stream "~%~%Semantic Error: Class '~a' expects ~a formal parameter(s)"
		  name num-formals)
        (format stream "~%                but got ~a actual parameter(s)."
		  num-actuals)
        (setq *match-errors* (+ 1 *match-errors*))
	(setq *rule-error* t)
      ) 
   )
)

;******************************************************************************
; count-formals methods
;
; As the object hierarchy is traversed, the property 'num-of-formals is set
; for every rulename.
;******************************************************************************

(defmethod (repetition :count-formals) ()
   (loop for each-element in child do 
      (send each-element ':count-formals)))

(defmethod (construction :count-formals) ()
   (loop for each-element in (send self ':child) do 
      (if each-element (send each-element ':count-formals))))

(defmethod (terminal :count-formals) () nil)

; rule = < rulename > ident [ formalparameters ] body "." 
;
(defmethod (rule :count-formals) ()
   (if formalparameters then
      (setf (get (send rulename ':val) 'num-of-formals)
         (send  formalparameters ':count-formals)))
)

; formalparameters = "(" , < formals > formalparameter-commalist ")" .
;
(defmethod (formalparameters :count-formals) ()
   (send formals ':count-formals)
)

; formalparameter-commalist ~ formalparameter { "," formalparameter } 
;
(defmethod (formalparameter-commalist :count-formals) ()
   (length (send self ':child))
)

; qualident = < moduleorinstname > ident [ "$" < selected > ident ] .
;
(defmethod (qualident :get-name) ()
   (send moduleorinstname ':val)
)


;*****************************************************************************
; These are by Bill Parker
;*****************************************************************************
;
; grammar = < rules > rule-list
;
(defmethod (grammar :label-instance-formal) ()
   (setq *label-instance-formal-errors* 0)
   (send rules ':label-instance-formal)
   *label-instance-formal-errors*
)

;
; rule-list ~ {rule}
;
(defmethod (rule-list :label-instance-formal) () 
   (loop for each-rule in child do
      (send each-rule ':label-instance-formal each-rule))
)

;
; rule = <rulename> ident [ formalparameters ] body "."
;
(defmethod (rule :label-instance-formal) (The-rule)
   (if formalparameters
      (send Body ':label-instance-formal The-rule
	 (flatten (send formalparameters ':get-formal-param))))
)

;
; repetitbody = "~" < first > stringorpp-list [ < nonempty > basicinstance ] < repeated > repeatedinstance < second > stringorpp-list 
;
(defmethod (repetitbody :label-instance-formal) (The-rule formal-params)
   nil
)

;
; constructbodycore = <elements> anyinstance-list
;
(defmethod (constructbodycore :label-instance-formal) (The-rule formal-params)
   (send elements ':label-instance-formal The-rule formal-params)
)

;
; alternatbody = ":" <alternatives> optstarredbasicinstance-barlist [ "*common*" <common> anyinstance-list ]
;
(defmethod (alternatbody :label-instance-formal) (The-rule formal-params)
   (if common (send common ':label-instance-formal The-rule formal-params))
)

;
; anyinstance-list ~ {anyinstance}
;
(defmethod (anyinstance-list :label-instance-formal) (The-rule formal-params)
   (let ((nonlabel-list nil))
        (do ((symbols child (cdr symbols))) ((null symbols) nil)
            (setq nonlabel-list (cons (send (car symbols) ':get-unlabeled-nonterminal) nonlabel-list))
 	) ; End of do
	(setq nonlabel-list (flatten nonlabel-list))
        (do ((items nonlabel-list (cdr items)) (bad-ones (list **semantic-error-symbol**)))
            ((null items) nil)
            (cond ((null (car items)))
	          ((and (not (member (car items) bad-ones))
			(member (car items) formal-params))
                           (format t "Semantic Error: The symbol '~A' does not have a label.~%" (car items))
			   (format t "An instance of a parameterized class must be labelled if it ~%")
			   (format t "contains a formal parameter. ~%")
			   (format t "The offending rule is:~%")
                           (send The-rule ':pp)
                           (format t "~%")
			   (setq *label-instance-formal-errors* (+ *label-instance-formal-errors* 1))
                           (setq bad-ones (cons (car items) bad-ones)))))))

;
; formalparameters = "(" <formals> formalparameter-commalist ")"
;
(defmethod (formalparameters :get-formal-param) ()
   (send formals ':get-formal-param)
)

;
; formalparameter-commalist ~ formalparameter { "," formalparameter }
;
(defmethod (formalparameter-commalist :get-formal-param) ()
   (loop for each-formalparameter in child collect
      (send each-formalparameter ':get-formal-param))
)

;
; formalparameter = < parametername > ident [ ":" < noofargs > number ] 
;
(defmethod (formalparameter :get-formal-param) ()
   (send parametername ':val)
)

;
; label-commalist-labeledinstance = < labels > label-commalist < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (label-commalist-labeledinstance :get-unlabeled-nonterminal) ()
   nil
)

;
; basicinstance-parassoc-commalist ~ basicinstance {"," basicinstance}
;
(defmethod (basicinstance-parassoc-commalist :get-unlabeled-nonterminal) ()
   (loop for each-basicinstance in child collect
      (send each-basicinstance ':get-unlabeled-nonterminal))
)

;
; basicinstance-parassoc = [ "=>" <formalparameter> ident ] <actualorformalparameter> basicinstance
;
(defmethod (basicinstance-parassoc :get-unlabeled-nonterminal) ()
   (send actualorformalparameter ':get-unlabeled-nonterminal)
)

;
; basicinstance = < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (basicinstance :get-unlabeled-nonterminal) ()
   (if actualparameters (send actualparameters ':get-unlabeled-nonterminal) (send instancename ':get-unlabeled-nonterminal))
)

;
; qualident = <moduleorinstname> ident [ "$" <selected> ident ]
;
(defmethod (qualident :get-unlabeled-nonterminal) ()
   (send moduleorinstname ':val)
)

;
; label-labeledinstance = < labels > label < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (label-labeledinstance :get-unlabeled-nonterminal) ()
   nil
)

;
; optionalinstance = "[" <left> stringorpp-list <inner> label-optlabeledinstance <right> stringorpp-list "]"
;
(defmethod (optionalinstance :get-unlabeled-nonterminal) ()
   (send inner ':get-unlabeled-nonterminal)
)

;
; inheritinstance = "*inherit*" < inheritsfrom > basicinstance-commalist [ "*override*" < overrides > label-commalist-labeledinstance-nonemptylist "*end*" ] 
;
(defmethod (inheritinstance :get-unlabeled-nonterminal) ()
   nil
)

;
; label-commalist ~ label {"," label}
;
(defmethod (label-commalist :get-unlabeled-nonterminal) ()
   nil
)

(defmethod (string :get-unlabeled-nonterminal) ()
   nil
)

;
; ppcommands 
;
(defmethod (ppcommands :get-unlabeled-nonterminal) ()
   nil
)


;
; grammar = <rules> rule-list
;
(defmethod (grammar :repetition-identical) ()
   (setq *repetition-identical* 0)
   (send rules ':repetition-identical)
   *repetition-identical*
)

;
; rule-list ~ { rule }
;
(defmethod (rule-list :repetition-identical) ()
   (loop for each-rule in child do
	 (send each-rule ':repetition-identical each-rule))
)

;
; rule = <rulename> ident [ formalparameters ] body "."
;
(defmethod (rule :repetition-identical) (The-Rule)
   (send body ':repetition-identical The-Rule)
)

;
; repetitbody = "~" <first> stringorpp-list [ <nonempty> basicinstance ] <repeated> repeatedinstance <second> stringorpp-list
;
(defmethod (repetitbody :repetition-identical) (The-Rule)
   (cond (nonempty (cond ((not (equal (send nonempty ':make-list-instances)
                      (send repeated ':make-list-instances)))
                      (format t "Semantic Error: Inconsistent Repetition Rule.  The outer and inner~%non-terminals must be the same.~%")
		      (format t "The offending rule is: ~%   ")
		      (send The-Rule ':pp)
                      (format t "~%")
		      (setq *repetition-identical* (+ *repetition-identical* 1))
                      ))))
)

;
; constructbody = "=" <elements> anyinstance-list
;
(defmethod (constructbody :repetition-identical) (The-rule)
  nil
)

;
; alternatbody = ":" <alternatives> optstarredbasicinstance-barlist [ "*common* <common> anyinstance-list ]
;
(defmethod (alternatbody :repetition-identical) (The-rule)
   nil
)

;
; uninstbody = "!" <elements> anyinstance-list
;
(defmethod (uninstbody :repetition-identical) (The-rule)
   nil
)

;
; instbody = "!!" <elements> anyinstance-list
;
(defmethod (instbody :repetition-identical) (The-rule)
   nil
)

;
; repeatedinstance = "{" <left> stringorpp-list <inner> basicinstance <right> stringorpp-list "}"
;
(defmethod (repeatedinstance :make-list-instances) ()
   (send inner ':make-list-instances)
)

;
; basicinstance = < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (basicinstance :make-list-instances) ()
   (cond (actualparameters (flatten (cons (send instancename ':get-nonterminal)
                			  (send actualparameters ':make-list-instances)))) 
         (t (send instancename ':get-nonterminal)))
)

;
; basicinstance-parassoc-commalist ~ basicinstance-parassoc { "," basicinstance-parassoc }
;
(defmethod (basicinstance-parassoc-commalist :make-list-instances) ()
   (loop for each-parassoc in child
      collect (send each-parassoc ':make-list-instances))
)

;
; basicinstance-parassoc = [ "=>" <formalparameter> ident ] <actualorformalparameter> basicinstance
;
(defmethod (basicinstance-parassoc :make-list-instances) ()
   (send actualorformalparameter ':make-list-instances)
)

;
; qualident = <moduleorinstname> ident [ "$" <selected> ident ]
;
(defmethod (qualident :get-nonterminal) ()
   (send moduleorinstname ':val)
)


;
; grammar = <rules> rule-list
;
(defmethod (grammar :non-par-classes-as-actual) ()
   (setq *non-pc-as-actual-errors* 0)
   (send rules ':non-par-classes-as-actual)
   *non-pc-as-actual-errors*
)

;
; rule-list ~ {rule}
;
(defmethod (rule-list :non-par-classes-as-actual) () 
   (loop for each-rule in child do
      (send each-rule ':non-par-classes-as-actual each-rule))
)

;
; rule = <rulename> ident [ formalparameters ] body "."
;
(defmethod (rule :non-par-classes-as-actual) (The-rule)
   (if formalparameters
      (send Body ':non-par-classes-as-actual The-rule
	 (flatten (send formalparameters ':get-formal-param))))
)

;
; repetitbody = "~" <first> stringorpp-list [<nonempty> basicinstance] <repeated> repeatedinstance <second> stringorpp-list
;
(defmethod (repetitbody :non-par-classes-as-actual) (The-rule formal-params)
   (send repeated ':non-par-classes-as-actual The-rule formal-params)
)

;
; constructbodycore = < elements > anyinstance-list 
;
(defmethod (constructbodycore :non-par-classes-as-actual) (The-rule formal-params)
   (send elements ':non-par-classes-as-actual The-rule formal-params)
)

;
; alternatbody = ":" <alternatives> optstarredbasicinstance-barlist [ "*common*" <common> anyinstance-list ]
;
(defmethod (alternatbody :non-par-classes-as-actual) (The-rule formal-params)
   (send alternatives ':non-par-classes-as-actual The-rule formal-params)
)

;
; formalparameters = "(" <formals> formalparameter-commalist ")"
;
(defmethod (formalparameters :get-formal-param) ()
   (send formals ':get-formal-param)
)

;
; formalparameter-commalist ~ formalparameter {"," formalparameter}
;
(defmethod (formalparameter-commalist :get-formal-param) ()
   (loop for each-formalparameter in child collect
      (send each-formalparameter ':get-formal-param))
)

;
; formalparameter = < parametername > ident [ ":" < noofargs > number ] 
;
(defmethod (formalparameter :get-formal-param) ()
   (send parametername ':val)
)

;
; anyinstance-list ~ {anyinstance}
;
(defmethod (anyinstance-list :non-par-classes-as-actual) (The-rule formal-params)
   (loop for each-anyinstance in child do
      (send each-anyinstance ':non-par-classes-as-actual The-rule formal-params))
)

;
; repeatedinstance = "{" <left> stringorpp-list <inner> basicinstance <right> stringorpp-list "}"
;
(defmethod (repeatedinstance :non-par-classes-as-actual) (The-rule formal-params)
   (send inner ':non-par-classes-as-actual The-rule formal-params)
)

;
; optstarredbasicinstance-barlist ~ optstarredbasicinstance { "|" optstarredbasicinstance }
;
(defmethod (optstarredbasicinstance-barlist :non-par-classes-as-actual) (The-rule formal-params)
   (loop for each-starredinstance in child do
      (send each-starredinstance ':non-par-classes-as-actual The-rule formal-params))
)

;
; instance = *common* <instancename> qualident [<actualparameters> basicinstance-parassoc-commalist]
;
(defmethod (instance :non-par-classes-as-actual) (The-rule formal-params)
   (cond ((and (member (send instancename ':get-instancename) formal-params) actualparameters)
               (format t "Semantic Error: Actual parameters for formal class parameters ~%")
	       (format t "must be non-parameterized classes. ~%")
	       (format t "The offending rule is:~%")
	       (send The-rule ':pp)
	       (format t "~%")
	       (setq *non-pc-as-actual-errors* (+ *non-pc-as-actual-errors* 1)))
	  (actualparameters (send actualparameters ':non-par-classes-as-actual The-rule formal-params)))
)

;
; starredinstance = "*" < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (starredinstance :non-par-classes-as-actual) (The-rule formal-params)
   (cond ((and (member (send instancename ':get-instancename) formal-params) actualparameters)
               (format t "Semantic Error: Actual parameters for formal class parameters ~%")
	       (format t "must be non-parameterized classes. ~%")
	       (format t "The offending rule is:~%")
	       (send The-rule ':pp)
	       (format t "~%")
	       (setq *non-pc-as-actual-errors* (+ *non-pc-as-actual-errors* 1)))
	  (actualparameters (send actualparameters ':non-par-classes-as-actual The-rule formal-params)))
)

;
; basicinstance-parassoc-commalist ~ basicinstance-parassoc { "," basicinstance-parassoc}
;
(defmethod (basicinstance-parassoc-commalist :non-par-classes-as-actual) (The-rule formal-params)
   (loop for each-basicinstance in child do
      (send each-basicinstance ':non-par-classes-as-actual The-rule formal-params))
)

;
; basicinstance-parassoc = [ "=>" <formalparameter> ident] <actualorformalparameter> basicinstance
;
(defmethod (basicinstance-parassoc :non-par-classes-as-actual) (The-rule formal-params)
   (send actualorformalparameter ':non-par-classes-as-actual The-rule formal-params)
)

;
; basicinstance = < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (basicinstance :non-par-classes-as-actual) (The-rule formal-params)
   (cond ((and (member (send instancename ':get-instancename) formal-params) actualparameters)
               (format t "Semantic Error: Actual parameters for formal class parameters ~%")
	       (format t "must be non-parameterized classes. ~%")
	       (format t "The offending rule is:~%")
	       (send The-rule ':pp)
	       (format t "~%")
	       (setq *non-pc-as-actual-errors* (+ *non-pc-as-actual-errors* 1)))
         (actualparameters (send actualparameters ':non-par-classes-as-actual The-rule formal-params)))
)

;
; qualident = <moduleorinstname> ident ["$" <selected> ident]
;
(defmethod (qualident :get-instancename) ()
   (send moduleorinstname ':val)
)

;
; inheritinstance = "*inherit*" < inheritsfrom > basicinstance-commalist [ "*override*" < overrides > label-commalist-labeledinstance-nonemptylist "*end*" ] 
;
(defmethod (inheritinstance :non-par-classes-as-actual) (The-rule formal-params)
   nil
)

;
; optionalinstance = "[" <left> stringorpp <inner> label-optlabeledinstance <right> stringorpp "]"
;
(defmethod (optionalinstance :non-par-classes-as-actual) (The-rule formal-params)
  (send inner ':non-par-classes-as-actual The-rule formal-params)
)

(defmethod (string :non-par-classes-as-actual) (The-rule formal-params)
   nil
)

(defmethod (ppcommands :non-par-classes-as-actual) (The-rule formal-params)
   nil
)


;
; grammar = <rules> rule-list
;
(defmethod (grammar :unique-instance-var-names) ()
   (setq *unique-instance-var-names-errors* 0)
   (send rules ':unique-instance-var-names)
   *unique-instance-var-names-errors*
)

;
; rule-list ~ {rule}
;
(defmethod (rule-list :unique-instance-var-names) () 
   (loop for each-rule in child do
      (send each-rule ':unique-instance-var-names each-rule))
)

;
; rule = <rulename> ident [formalparameters] body "."
;
(defmethod (rule :unique-instance-var-names) (The-rule)
   (send Body ':unique-instance-var-names The-rule)
)

;
; repetitbody = "~" <first> stringorpp-list [<nonempty> basicinstance] <repeated> repeatedinstance <second> stringorpp-list
;
(defmethod (repetitbody :unique-instance-var-names) (The-rule)
   nil)

;
; constructbodycore = <elements> anyinstance-list
;
(defmethod (constructbodycore :unique-instance-var-names) (The-rule)
   (send elements ':unique-instance-var-names The-rule)
)

;
; alternatbody = ":" < alternatives > optstarredbasicinstance-barlist [ "*common*" < common > anyinstance-list ] 
;
(defmethod (alternatbody :unique-instance-var-names) (The-rule)
   (if common (send common ':unique-instance-var-names The-rule))
)

;
; anyinstance-list ~ { anyinstance } 
;
(defmethod (anyinstance-list :unique-instance-var-names) (The-rule)
   (let ((label-list nil))
        (do ((symbols child (cdr symbols))) ((null symbols) nil)
            (setq label-list (cons (send (car symbols) ':get-label-or-nonterminal) label-list))
	) ; End of do
        (setq label-list (flatten label-list))
        (do ((items label-list (cdr items)) (bad-ones (list **semantic-error-symbol**)))
            ((null items) nil)
            (cond ((null (car items)))
                  ((and (member (car items) (cdr items)) (not (member (car items) bad-ones)))
                        (format t "Semantic Error: The symbol '~A' was used multiple times.~%" (car items))
			(format t "If used to denote the same non-terminal twice then one or both~%")
		        (format t "occurrences should be proceeded by a label.  Other possible~%")
		        (format t "problems are two labels with the same name or a non-terminal~%")
			(format t "symbol and a label with the same name.  NOTE: Be sure to check~%")
			(format t "inherited classes.~%")
		        (format t "The offending rule is:~%")
                        (send The-rule ':pp)
                        (format t "~%")
			(setq *unique-instance-var-names-errors* (+ *unique-instance-var-names-errors* 1))
                        (setq bad-ones (cons (car items) bad-ones)))))))

;
; label-commalist-labeledinstance = < labels > label-commalist < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (label-commalist-labeledinstance :get-label-or-nonterminal) ()
   (send labels ':get-label-or-nonterminal)
)

;
; basicinstance = < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] . 
;
(defmethod (basicinstance :get-label-or-nonterminal) ()
   (send instancename ':get-label-or-nonterminal)
)

;
; qualident = < moduleorinstname > ident [ "$" < selected > ident ]
;
(defmethod (qualident :get-label-or-nonterminal) ()
   (send moduleorinstname ':val)
)

;
; label-labeledinstance = < labels > label < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] 
;
(defmethod (label-labeledinstance :get-label-or-nonterminal) ()
   (send labels ':get-label-or-nonterminal)
)

;
; optionalinstance = "[" <left> stringorpp-list <inner> label-optlabeledinstance <right> stringorpp-list "]"
;
(defmethod (optionalinstance :get-label-or-nonterminal) ()
   (send inner ':get-label-or-nonterminal)
)

;
; inheritinstance = "*inherit*" < inheritsfrom > basicinstance-commalist [ "*override*" < overrides > label-commalist-labeledinstance-nonemptylist "*end*" ] 
;
(defmethod (inheritinstance :get-label-or-nonterminal) ()
   (send inheritsfrom ':get-expand-instances)
)

;
; label-commalist ~ label {"," label}
;
(defmethod (label-commalist :get-label-or-nonterminal) ()
   (loop for each-label in child collect
      (send each-label ':get-label-or-nonterminal))
)

;
; label = "<" <labelname> ident ">"
;
(defmethod (label :get-label-or-nonterminal) ()
   (send labelname ':val)
)

(defmethod (string :get-label-or-nonterminal) ()
   nil
)

(defmethod (ppcommands :get-label-or-nonterminal) ()
   nil
)


;-----------------------------------------------------------------------------
; method :get-expand-instances
;   get all the instance variables from the inheritance
;-----------------------------------------------------------------------------

;
; CommaList(S) ~ S {"," S}.
; basicinstance-commalist ~ basicinstance { "," basicinstance } . 
;
(defmethod (commalist :get-expand-instances) ()
    (loop for each-instance in child collect
          (send each-instance ':get-expand-instances))
)

;
; basicinstance = < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] . 
;
(defmethod (basicinstance :get-expand-instances) ()
    (send instancename ':get-expand-instances)
)

;
; qualident = < moduleorinstname > ident [ "$" < selected > ident ]
;
(defmethod (qualident :get-expand-instances) ()
    (send *head* ':look-up-get (send moduleorinstname ':val))
)

;
; grammar = < rules > rule-list
;
(defmethod (grammar :look-up-get) (rule-name)
    (send rules ':look-up-get rule-name)
)

;
; rule-list ~ { rule } 
;
(defmethod (rule-list :look-up-get) (rule-name)
    (loop for each-rule in child
          for expand = (send each-rule ':look-up-get rule-name)
      when expand return expand
      finally (return nil))
)


;
; rule = < rulename > ident [ formalparameters ] body "." 
;
(defmethod (rule :look-up-get) (rule-name)
  (if (eql (send rulename ':val) rule-name)
      (send body ':look-up-get))
)

;
; constructbodycore = < elements > anyinstance-list 
;
(defmethod (constructbodycore :look-up-get) ()
    (send elements ':get-expand-instances)
)

;
; alternatbody = ":" < alternatives > optstarredbasicinstance-barlist [ "*common*" < common > anyinstance-list ] 
;
(defmethod (alternatbody :look-up-get) ()
    (if common
        (send  common ':get-expand-instances)
    )
)

;
; repetitbody = "~" < first > stringorpp-list [ < nonempty > basicinstance ] < repeated > repeatedinstance < second > stringorpp-list 
;
(defmethod (repetitbody :look-up-get) ()
  nil
)

;
; anyinstance-list ~ { anyinstance } 
;
(defmethod (anyinstance-list :get-expand-instances) ()
    (loop for each-anyinstance in child collect
          (send each-anyinstance ':get-label-or-nonterminal))
)


(defun flatten (lyst)
   (cond ((null lyst) nil)
	 ((atom lyst) (list lyst))
	 (t (append (flatten (car lyst)) (flatten (cdr lyst)))))
)

;*****************************************************************************
; END of BILL PARKER'S checks
;*****************************************************************************


;*****************************************************************************
; Qixiong Bian
; COM 3205 Software Design and Development   Spring 1988
; Project 3 - Semantic Checking and Documentation of Parameterized Class
; Dictionaries
; Semantic Check #5 - Parameterized-Common: If a parameterized class is defined
; by an alternation production which uses *common* then all the alternatives
; have to use all the formal parameters.  An error message is printed for
; every alternation production that violates this rule.
;*****************************************************************************
;
;
; grammar = < rules > rule-list *l .
;
(defmethod (grammar :parameterized-common) ()
   (setq *parameterized-common-errors* 0)
   (send rules ':parameterized-common)
   *parameterized-common-errors*
)
;
; rule-list ~ { rule } .
;
(defmethod (rule-list :parameterized-common) ()
   (loop for each-rule in child do
      (send each-rule ':find-rule))
)


;*****************************************************************************
; The find-rule method is defined to find out the rules which have
; formalparameters and alternatbodies with *common*.
; The body-type method is defined to find out the alternatbodies and
; the body-common method is defined to find out the alternatbodies with
; *common*.
;*****************************************************************************
;
; rule = *l < rulename > ident [ formalparameters ] body "." .
;
(defmethod (rule :find-rule) ()
   (if formalparameters
      (if (send body ':body-type)
	 (if (send body ':body-common)
	    (send self ':parameterized-common))))
)
;
(defmethod (rule :parameterized-common) ()
   (setq *rule-error* nil)
   (setq *rulename* (send rulename ':val))
   (send self ':get-parameters)
   (send body ':parameterized-common)
   (if *rule-error* then
      (format stream "~%~%The above error(s) occurred in the rule:")
      (send self ':pp stream))
)
;
; alternatbody = ":" < alternatives > optstarredbasicinstance-barlist [ "*common*" < common > anyinstance-list ] .
;
(defmethod (alternatbody :parameterized-common) ()
   (send alternatives ':parameterized-common)
)
;
; optstarredbasicinstance-barlist ~ optstarredbasicinstance { "|" optstarredbasicinstance } .
;
(defmethod (optstarredbasicinstance-barlist :parameterized-common) ()
   (loop for each-optstarredbasicinstance in child do
      (send each-optstarredbasicinstance ':parameterized-common))
)
;
; optstarredbasicinstance : basicinstance | starredinstance .
;
; basicinstance = < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] .
;
(defmethod (basicinstance :parameterized-common) ()
   (let* ((formals-of-instance nil) (name *rulename*)
	  (formals-of-rulename (get name 'formals-rulename)))
         (if actualparameters then
	    (setq formals-of-instance (send actualparameters ':get-parameters)))
         (if (not (equal formals-of-instance formals-of-rulename)) then
	    (format stream "~%~%Semantic Error: Class '~a' has formal parameter(s) '~a'"
	       name formals-of-rulename)
            (format stream "~%                Alternative '~a' has formal parameter(s) '~a'"
	       (send instancename ':get-name) formals-of-instance)
            (setq *parameterized-common-errors* (+ 1 *parameterized-common-errors*))
	    (setq *rule-error* t))
   )
)
;
; starredinstance = "*" < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] .
;
(defmethod (starredinstance :parameterized-common) ()
   (let* ((formals-of-instance nil) (name *rulename*)
	  (formals-of-rulename (get name 'formals-rulename)))
         (if actualparameters then
	    (setq formals-of-instance (send actualparameters ':get-parameters)))
         (if (not (equal formals-of-instance formals-of-rulename)) then
	    (format stream "~%~%Semantic Error: Class '~a' has formal parameter(s) '~a'"
	       name formals-of-rulename)
            (format stream "~%                Alternative 'a' has formal parameter(s) '~a'"
	       (send instancename ':get-name) formals-of-instance)
            (setq *parameterized-common-errors* (+ 1 *parameterized-common-errors*))
	    (setq *rule-error* t))
   )
)
;*****************************************************************************
; The get-parameters method is defined to get the parameters in the rulename
; and the instances of the body of the rule.
;*****************************************************************************
;
; rule = *l < rulename > ident [ formalparameters ] body "." .
;
(defmethod (rule :get-parameters) ()
   (setf (get (send rulename ':val) 'formals-rulename)
      (send formalparameters ':get-parameters))
)
;
; formalparameters = "(" < formals > formalparameter-commalist ")" .
;
(defmethod (formalparameters :get-parameters) ()
   (send formals ':get-parameters)
)
;
; formalparameter-commalist ~ formalparameter { "," formalparameter } .
;
(defmethod (formalparameter-commalist :get-parameters) ()
   (loop for each-formalparameter in child collect
      (send each-formalparameter ':get-name))
)
;
; formalparameter = < parametername > ident [ ":" < noofargs > number ] .
;
(defmethod (formalparameter :get-name) ()
   (send parametername ':val)
)
;
; basicinstance-parassoc-commalist ~ basicinstance-parassoc { "," basicinstance-parassoc } .
;
(defmethod (basicinstance-parassoc-commalist :get-parameters) ()
   (loop for each-basicinstance-parassoc in child collect
      (send each-basicinstance-parassoc ':get-name))
)
;
; basicinstance-parassoc = [ "=>" < formalparameter > ident ] < actualorformalparameter > basicinstance .
;
(defmethod (basicinstance-parassoc :get-name) ()
   (send actualorformalparameter ':get-name)
)
;
; basicinstance = < instancename > qualident [ "(" < actualparameters > basicinstance-parassoc-commalist ")" ] .
;
(defmethod (basicinstance :get-name) ()
   (send instancename ':get-name)
)
;
; qualident = < moduleorinstname > ident [ "$" < selected > ident ] .
;
(defmethod (qualident :get-name) ()
   (send moduleorinstname ':val)
)
;
; body : constructbody | repetitbody | alternatbody | neutralbody .
;
(defmethod (constructbody :body-type) ()
   nil
)
;
(defmethod (repetitbody :body-type) ()
   nil
)
;
(defmethod (alternatbody :body-type) ()
   t
)
;
(defmethod (neutralbody :body-type) ()
   nil
)
;
; alternatbody = ":" < alternatives > optstarredbasicinstance-barlist [ "*common*" < common > anyinstance-list ] .
;
(defmethod (alternatbody :body-common) ()
   (if common (send self ':get-value))
)
;
(defmethod (alternatbody :get-value) ()
   t
)

;*****************************************************************************
; END OF QIXIONG BIAN's
; COM 3205 Software Design and Development   Spring 1988
; Project 3 - Semantic Checking and Documentation of Parameterized Class
; Dictionaries
;*****************************************************************************


; These are fixes.
;
;qualident = < moduleorinstname > ident [ "$" < selected > ident ] . 
;
(defmethod (QualIdent :val) ()
   (send moduleOrInstName ':val)
)

(defmethod (QualIdent :find-recursives) (rulename formalparm)
   (send moduleOrInstName ':find-recursives rulename formalparm)
)

(defmacro debug-before (method-name) 
   `(defmethod (Universal :before ,method-name) (&rest args)
       (format t "Entering the method ~A with object ~A~%" ',method-name (send-self ':type))))

(defmacro debug-after (method-name)
   `(defmethod (Universal :after ,method-name) (&rest args)
       (format t "Exiting the method ~A with object ~A~%" ',method-name (send-self ':type))))


(debug-before :check-regularity)
(debug-before :check-regularity-aux)
(debug-after :check-regularity)
(debug-after :check-regularity-aux)
(debug-before :find-recursives)
(debug-before :find-recursives-aux)
(debug-after :find-recursives)
(debug-after :find-recursives-aux)