(dmd desetq (l1 l2) `(deset ',l1 ,l2))
	
;===============================================================================
;
;                      G R A M M A R    O B J E C T S
;
; This example is given to demonstrate some object modeling techniques using
; metaclasses. The problem chosen for this purpose is to have an object 
; representation of a grammar with its tokens, non-terminals, ... and then
; to use all these objects in order to build a parser.
;
; See also parser.wl for parser creation and sample.grm for having an 
; executable example.
;===============================================================================

; -----------------------------------------------------------------------------
; The problem can be stated as:
; 	a grammar element is an object that shares the grammar object G
; 	with all the other grammar elements referenced within the same 
;	grammar G.
;
; A simple solution for implementing this is to have an instance variable 
; that contains G in all kinds of grammar element:
;
;	[{AbstractClass} new 'name 'GrammarElement
;		'superClass		{Object}
;        	'instanceVariables	'(grammar)]
; 
;	[{Class} new 'name 'NonTerminal
;		'superClass		{GrammarElement}
;        	'instanceVariables	'(name productions)]
;
;	[{Class} new 'name 'Production
;				. . .
;
; But that means duplicating the information G and not really sharing it.     
;
; To avoid this drawback, all the elements of the same grammar G will
; be created as instances of some classes inside which G will be wired.
; Let's call these classes the grammar element classes PRIVATE TO G:
; 			How this could be done ?
; For these private classes considered as some objects, G will be stored 
; in their instance variable called <grammar>. 
; Thus for the instances of these private classes, G is available through 
; the CLASS VARIABLE called <grammar>.
; -----------------------------------------------------------------------------

[{Class} new 'name 'MetaGrammarElement
	'superClass		{Class}
        'instanceVariables	'(grammar)]
        
; -----------------------------------------------------------------------------
; The following classes define the structure end behavior of all kinds of
; grammar elements but can't be used directly to create grammar elements
; since they don't hold any grammar object that can be shared by their
; instances.
;
; Notice here that we would like to let <MetaAbstractGrammarElement> inherits
; from <MetaGrammarElement> to get the instance variable <grammar> AND from
; <AbstractClass> to have the method for <new> redefined as an error.
; -----------------------------------------------------------------------------

[{Class} new 'name 'MetaAbstractGrammarElement
	'superClass		{MetaGrammarElement}
        'methods		'(
new ( inits
      (error "{MetaAbstractGrammarElement}:new" 
             "abstract grammar element classes cannot be instantiated" self))
)]
 
[{MetaAbstractGrammarElement} new 'name 'AbstractGrammarElement
	'superClass		{Object}
        'grammar		()
        'methods		'(
grammar (()		#Cgrammar)
)]                                   

[{MetaAbstractGrammarElement} new 'name 'AbstractNonTerminal
	'superClass		{AbstractGrammarElement}
        'instanceVariables	'(name productions)
        'grammar		()]

[{MetaAbstractGrammarElement} new 'name 'AbstractProduction
	'superClass		{AbstractGrammarElement}
        'instanceVariables	'(body action)
        'grammar		()]

[{MetaAbstractGrammarElement} new 'name 'AbstractToken
	'superClass		{AbstractGrammarElement}
        'instanceVariables	'(name value)
        'grammar		()]

[{MetaAbstractGrammarElement} new 'name 'AbstractErrorToken
	'superClass		{AbstractGrammarElement}
        'grammar		()]
 
; -----------------------------------------------------------------------------
; Notice here the 'private to <newGrammar>' grammar element classes creation 
; with:
;
;	[{MetaGrammarElement} new 
;	      	'name       (concat 'NonTerminal newSymbol)
;       	'superClass {AbstractNonTerminal}
;               'grammar    newGrammar]
;
; and their storage in the nonTerminalClass, productionClass, ... instance
; variables of <newGrammar>, the newly created instance of Grammar.
; -----------------------------------------------------------------------------

[{Class} new 'name 'MetaGrammar
	'superClass		{Class}
        'methods		'(
new ((grammarFileName)	[[super new] initialize grammarFileName])
)]

[{MetaGrammar} new 'name 'Grammar
	'superClass		{Object}
        'instanceVariables	'(nonTerminalClass productionClass tokenClass
                                  errorTokenClass dictionary)
        'methods		'(
initialize ((grammarFileName)                                   
	    (let ( (newSymbol  [{symbol} new]) )
	         (setf #InonTerminalClass
                       [{MetaGrammarElement} new 
        			'name       (concat 'NonTerminal newSymbol)
                                'superClass {AbstractNonTerminal}
                                'grammar    self]
                       #IproductionClass
                       [{MetaGrammarElement} new 
        			'name       (concat 'Production newSymbol)
                                'superClass {AbstractProduction}
                                'grammar    self]
                       #ItokenClass
                       [{MetaGrammarElement} new 
        			'name       (concat 'Token newSymbol)
                                'superClass {AbstractToken}
                                'grammar    self]
                       #IerrorTokenClass
                       [{MetaGrammarElement} new 
        			'name       (concat 'ErrorToken newSymbol)
                                'superClass {AbstractErrorToken}
                                'grammar    self]
                       #Idictionary	[{Dictionary} new])
                 [self buildDictionary grammarFileName]
                 self))

buildDictionary ((grammarFileName)
                 ;; ------------------------------------------------------------
                 ;; In order to build the grammar elements dictionary, a grammar
                 ;; file is parsed (with a hand coded recursive descent parser)
                 ;; the format of a grammar file is:
                 ;;
                 ;; grammarFile -> [lispCode] '%%' 
                 ;;                {grammarRule}+          ;1 or more rules...
                 ;;                ['%%' lispCode]
                 ;;
                 ;; grammarRule -> nonTerminalSymbol ':' productions ';'
                 ;;
                 ;; productions -> production '|' productions
                 ;;             -> production
                 ;;
                 ;; production -> body [action]
                 ;;
                 ;; body -> {grammarSymbol}*              ;0 or more symbols...
                 ;;
                 ;; grammarSymbol -> nonTerminalSymbol 
                 ;;               -> '%'tokenSymbol
                 ;;               -> '%error'
                 ;;
                 ;; action -> '(' lambdaFunctionOrLispFunctionName ')'
                 ;; ------------------------------------------------------------
          		(unless (probefile grammarFileName)
                                (error "{Grammar}:buildDictionary" 
                                       "unknown file" grammarFileName))
                        (with ( (inchan (openi grammarFileName)) )
                              (untilexit eof 
                                         (let ( (x (read)) )
                                              (if (eq x '%%) 
                                                  (untilexit grammarRules
                                                          [self addNonTerminal])
                                                  ;;ELSE
                                                  (eval x)))))
                        [self checkDictionary]
                        self)

addNonTerminal (()
       		(let ( ((type1 . name)   [self scan])
                       ((type2 . sep)    [self scan]) 
                       (productions) )
                     (unless (and (eq type1 'symbol) 
                                  (eq type2 'first-body-sep))
                             (error "{Grammar}:addNonTerminal"
                                    "expected <non-terminal name> ':', got"
                                    (cons name sep)))
                     ;; grammarRule AND NO OTHER TAG MUST BE EXITED FROM HERE...
                     (newl productions 
                           (lock '(lambda (tag lastProduction)
                                          (if (eq tag 'grammarRule)
                                              lastProduction
                                              ;;ELSE
                                              (error "{Grammar}:addNonTerminal"
                                                     "unexpected end of rule"
                                                     ())))
                                 (while t	
         			        (newl productions 
         			              [self addProduction]))))
                     [#Idictionary at name 
                     	              [#InonTerminalClass new
                               		'name        name 
                                        'productions (nreverse productions)]]))
                     
addProduction (()
       		(let ( (dictionary      #Idictionary)
                       (tokenClass      #ItokenClass)
                       (errorTokenClass #IerrorTokenClass)
                       (type) (val) (body) (action) (production) ) 
                     (untilexit body
                                (desetq (type . val) [self scan])
                                (cond ( (eq type 'symbol)
                                        (newl body val)
                                        (unless [dictionary at val]
                                                [dictionary at val ()]) )
                                      ( (eq type 'token)
                                        (newl body val)
                                        (unless [dictionary at val]
                                                [dictionary at val
                                                               [tokenClass new 
                                                           	 'name   val
                                                                 'value  ()]]) )
                                      ( (eq type 'error)
                                        (newl body val)
                                        (unless [dictionary at val]
                                                [dictionary at val
                                                       [errorTokenClass new]]) )
                                      ( t	(exit body t) )))
                     (when (eq type 'cons)
                           (setq   action       (car val))
                           (desetq (type . val) [self scan]))
                     (setq production [#IproductionClass new 
                           			'body (nreverse body) 
                                                'action action])
                     (cond ( (eq type 'body-sep)	production )
                           ( (eq type 'rule-sep)	(exit grammarRule 
                                                              production) )
                           ( t
                             (error "{Grammar}:addProduction"
                                    "expected '|' or ';', got"
                                    val) ))))
                  
scan (()
       (let ( (c (peekcn)) )
            (selectq c
                     ( #/:
                       (cons 'first-body-sep (readcn)) )
                     ( #/|
                       (cons 'body-sep (readcn)) )
                     ( #/;
                       (cons 'rule-sep (readcn)) )
                     ( #/%
                       (readcn)
                       (when (eq (peekcn) #/%)
                             (exit grammarRules (readcn) t))
                       (let ( (x (read)) )
                            (unless (variablep x)
                                    (error "{Grammar}:scan"
                                           "expected '%'<token name>, got '%'"
                                           x))
                            (if (eq x 'error) 
                                '(error . error) 
                                ;;ELSE
                                (cons 'token x))) )
                     ( t
                       (cond ( (member (typecn c) '(csep cecom))
                               (readcn)
                               [self scan] )
                             ( t
                               (let ( (x (read)) ) (cons (type-of x) x)) )) ))))
                  
checkDictionary (()
			(let ( (dictionary #Idictionary)
                               (missingElements) )
                             (when [dictionary isEmpty]
                                   (error "{Grammar}:checkDictionary" 
                                          "grammar elements not found" ()))
                             [dictionary do '(lambda (name element)
                                                (unless element
                                                        (newl missingElements 
                                                              name)))]
                             (when missingElements
                                   (error "{Grammar}:checkDictionary"
                                          "undefined non terminals" 
                                          missingElements))
                             self))

element ((name)		[#Idictionary at name])

prin (()
      ;; -------------------------------------------------------------------
      ;; circular structures ...
      ;; Without this method, the standard lisp printer will loop while
      ;; trying to print a Grammar Object (because its private classes
      ;; contains some references to itself).
      ;; -------------------------------------------------------------------
	(prin "aGrammar"))
)]
 



