;;; -*- Mode: COMMON-LISP; Fonts:(MEDFNT HL12B HL12I MEDFNB); Package: PASCALX; Base: 10 -*-



3(DEFCONSTANT ADDING-OPERATOR-ALIST* '((plus  . *plus-op*)
					 (minus . *minus-op*)
					 (or    . *or-op*))
  2"the alist to determine the internal representation of an adding operator"*)

3(DEFCONSTANT ALL-DIRECTIVES* '(forward external)
   2"the allowed directives"*)

3(DEFCONSTANT MULTIPLYING-OPERATOR-ALIST* '((star  . *times-op*)
					       (slash . *divide-op*)
					       (div   . *int-divide-op*)
					       (mod   . *mod-op*)
					       (and   . *and-op*))
  2"the alist to determine the internal format of a multiplying operator"*)

3(DEFCONSTANT RELATION-OPERATOR-ALIST* '((equal . *eq-op*)
				       (ne    . *ne-op*)
				       (lt    . *lt-op*)
				       (gt    . *gt-op*)
				       (le    . *le-op*)
				       (ge    . *ge-op*)
				       (in    . *in-op*))
  2"the alist to find the internal name for relational operators"*)

3(DEFCONSTANT SIGN-ALIST* '((plus . *unary-plus*)
			     (minus . *unary-minus*))
  2"the alist to determine the internal representation of sign"*)


3(DEFUN ACCESSOR (so-far)*
  2"the production is accessor -> '[' expression { ',' expression } ']' | '.' identifier | '^' ."*
  (let ((tok1 (lexi)))
    (case (token-type tok1)
      (left-brck
       (loop with result = (list (make-operator-from-token '*array-accessor* tok1)
				 so-far
				 (expression))
	     for tok = (lexi)
	     while (eq (token-type tok) 'comma)
	     do (setf result (list (make-operator-from-token '*array-accessor* tok)
				   result
				   (expression)))
	     finally (cond ((not (eq (token-type tok) 'right-brck))
			    (parser-error "expected a right bracket (]) at the end of" 'accessor tok)))
	     (return result)))
      (period (list (make-operator-from-token '*record-accessor* tok1)
		    so-far
		    (identifier 'accessor)))
      (up-arrow (list (make-operator-from-token '*pointer-accessor* tok1)
		      so-far))))
  );1accessor


3(DEFUN ACTUAL-PARAMETER ()**
  2"The production is: actual-parameter -> expression [ ':' expression [ ':' expression ] ] ."*
  (let (tok1 tok2 exp1 exp2 exp3)
    (setf exp1 (expression))
    (cond ((not (eq (token-type (peek-at-token)) 'colon))
	   exp1)
	  (t (setf tok1 (lexi))
	     (setf exp2 (expression))
	     (cond ((eq (token-type (peek-at-token)) 'colon)
		    (setf tok2 (lexi))
		    (setf exp3 (expression))))
	     (list (IF tok1
		       (append-comment-to-last-operator exp1
							(token-comment
							    tok1))
		       nil)
		   (IF tok2
		       (append-comment-to-last-operator exp2
							(token-comment
							    tok2))
		       nil)
		   exp3))))
  );1actual-parameter


3(DEFUN ACTUAL-PARAMETER-LIST ()**
  2"The production is: actual-parameter-list -> '(' actual-parameter { ';' actual-parameter } ')' ."*
  (let ((tok1 (lexi))
	first-ap)
    (cond ((not (eq (token-type tok1) 'left-paren))
	   (parser-error "left parenthesis expected at the beginning of" 'actual-parameter-list tok1)))
    (setf first-ap (actual-parameter))
    (append-comment-to-last-operator (oper first-ap) (token-comment tok1))
    (loop for ap first first-ap then (actual-parameter)
	  and tok = (lexi)
	  do (append-comment-to-last-operator ap (token-comment tok))
	  collect ap
	  while (eq (token-type tok) 'comma)
	  finally (cond ((not (eq (token-type tok) 'right-paren))
			 (parser-error "right parenthesis expected at the end of"
				       'actual-parameter-list tok)))))
  );1actual-parameter-list


3(DEFUN ADDING-OPERATOR ()**
  2"The production is: adding-operator -> '+' | '-' | 'or' ."*
  (get-operator adding-operator-alist))


3(DEFUN $ARRAY-TYPE ()*
  2"The production is: array-type -> ARRAY '[' ordinal-type { ',' ordinal-type } ']'OF type-denoter .
Note: arrays can have only 1 dimension; ARRAY [<type1> <type2>...] is the same as:  ARRAY [<type1>] OF ARRAY [<type2>] ... "*
  (let* ((tok1 (lexi))			  ; should be ARRAY,
	 (tok2 (lexi))			  ; should be [
	 ty-den tok4 tok5 index-type rest-indices)
    (cond ((not (eq (token-type tok1) 'array))
	   (parser-error "expected ARRAY in the beginning of" '$array-type tok1)))
    (cond ((not (eq (token-type tok2) 'left-brck))
	   (parser-error "expected a left bracket ([) after ARRAY" '$array-type tok2)))
    (setf index-type (ordinal-type))
    (append-comment-to-last-operator (oper index-type) (token-comment tok2))
    (setf rest-indices
	  (loop while (eq (token-type (peek-at-token)) 'comma)
		collect (list (make-operator-from-token '*array-type* (lexi))
			      (ordinal-type))))
    (cond ((not (eq (token-type (setf tok4 (lexi))) 'right-brck))
	   (parser-error "expected a right bracket (]) after the index (ordinal) types" '$array-type tok4)))
    (cond ((not (eq (token-type (setf tok5 (lexi))) 'of))
	   (parser-error "expected OF followed by a type denoter" '$array-type tok5)))
    (setf ty-den (type-denoter))
    (append-comment-to-last-operator (append-comment-to-last-operator (oper ty-den) (token-comment tok5))
				     (token-comment tok4))
    (list (append-comment-to-last-operator (make-operator-from-token '*array-type* tok1)
					   (token-comment tok2))
	  index-type
	  (loop with result = ty-den
		for ty in (nreverse rest-indices)
		do (setf result (append ty (list result)))
		finally (return result))))
  );1$array-type


3(DEFUN ASSIGNMENT-STATEMENT ()**
  2"The production is: assignment-statement -> variable-access ':=' expression ."*
  (let* ((vara (variable-access))
	 (tok1 (lexi)))
    (cond ((not (eq (token-type tok1) 'assign))
	   (parser-error "expected := in" 'assignment-statement tok1)))
    (list (make-operator-from-token '*assignment-statement* tok1)
	  vara
	  (expression)))
  );1assign-statement


3(DEFUN $BLOCK ()**
  2"The production is: block -> label-declaration-part
                                    constant-definition-part
                                    type-definition-part
                                    variable-declaration-part
                                    procedure-and-function-declaration-part
                                    statement-part ."*
  (list
    (label-declaration-part)
    (constant-definition-part)
    (type-definition-part)
    (variable-declaration-part)
    (procedure-and-function-declaration-part)
    (statement-part))
  );1$block


3(DEFUN CASE-LIST-ELEMENT ()**
  2"The production is: case-list-element -> constant-list ':' statement ."*
  (let ((cnst-l (constant-list))	   ;1 should be CASE*
	tok1)
    (cond ((not (eq (token-type (setf tok1 (lexi))) 'colon))
	   (parser-error "expected : after constant in" 'case-list-element tok1)))
    (list (append-comment-to-last-operator cnst-l (token-comment tok1))
	  (statement)))
  );1case-list-element


3(DEFUN CASE-STATEMENT ()**
  2"The production is: case-statement -> CASE expression OF case-list-element { ';' case-list-element } [ ';' ] END ."*
  (let ((tok1 (lexi))
	tok2 exp)
    (cond ((not (eq (token-type tok1) 'case))
	   (parser-error "expected CASE at the beginning of" 'case-statement tok1)))
    (setf exp (expression))
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'of))
	   (parser-error "expected OF after case index" 'case-statement tok2)))
    (list (make-operator-from-token '*case-statement* tok1)
	  (append-comment-to-last-operator exp (token-comment tok2))
	  (loop for cle = (case-list-element)
		and tok = (lexi)
		and peek-tok = (peek-at-token)
		collect (append-comment-to-last-operator cle (token-comment tok))
		into op-list
		until (or (eq (token-type tok) 'end)
			  (eq (token-type peek-tok) 'end))
		finally (progn
			  (cond ((eq (token-type tok) 'semi-colon)
				 (append-comment-to-last-operator op-list
								  (token-comment
								    (setf tok (lexi))))))1  ; read the END.*
			  (cond ((not (eq (token-type tok) 'end))
				 (parser-error "need an END for" 'case-statement tok)))
			  (return op-list))))
    );1let*
  );1case-statement


3(DEFUN COMPOUND-STATEMENT ()**
  2"The production is: compound-statement -> BEGIN statement-sequence END ."*
  (let ((tok1 (lexi))			   1; should be BEGIN,*
	tok2 stmt-seq)
    (cond ((not (eq (token-type tok1) 'begin))
	   (parser-error "a BEGIN was expected at the beginning of" 'compound-statement tok1)))
    (setf stmt-seq (statement-sequence))
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'end))
	   (parser-error "no matching END for a BEGIN in" 'compound-statement tok2)))
    (list (make-operator-from-token '*compound-statement* tok1)
	  (append-comment-to-last-operator stmt-seq (token-comment tok2))))
  );1compound-statement


3(DEFUN CONDITIONAL-STATEMENT ()**
;   (declare (function conditional-statement () nil))
   (ecase (token-type (peek-at-token))
     (if   (if-statement))
     (case (case-statement)))
   );1conditional-statement


3(DEFUN CONSTANT ()**
  2"The production is: constant -> [ sign ] (unsigned-number | constant-identifier ) | character-string ."*
  (let* ((si (sign))
	 (tok1 (peek-at-token))
	 (tok-typ (token-type tok1))
	 cnst id)
    (cond ((or (eq tok-typ 'int-const) (eq tok-typ 'real-const))
	   (setf tok1 (lexi))
	   (setf cnst (list (make-operator-from-token '*number* tok1)
			    (get-constant tok1)))
	   (if si
	       (list si cnst)
	       cnst))
	  
	  ((setf id (identifier))
	   (if si
	       (list si id)
	       id))
	  
	  ((and (not si) (eq tok-typ 'string))
	   (setf tok1 (lexi))
	   (list (make-operator-from-token '*string* tok1)
		 (get-string tok1)))
	  
	  (t (parser-error
	       "a numeric constant or string constant expected, or a string with a sign found in"
	       'constant tok1))))
  );1constant


3(DEFUN CONSTANT-DEFINITION ()**
  2"The production is: constant-definition -> identifier '=' constant ."*
   (declare (values constant-id-value-pair))
   (let ((id (identifier 'constant-definition))
	 cnst tok2)
     (cond ((not (eq (token-type (setf tok2 (lexi))) 'equal))
	    (parser-error "expected EQUAL sign (=)" 'constant-definition tok2)))
     (setf cnst (constant))
     (list (append-comment-to-last-operator id (token-comment tok2))
	   cnst))
  );1constant-definition


3(DEFUN CONSTANT-DEFINITION-PART ()**
  2"The production is: constant-definition-part -> [ CONST constant-definition ';'{ constant-definition ';' } ] ."*
  (let ((ty (token-type (peek-at-token)))
	tok1)
    (cond ((eq ty 'const)
	   (setf tok1 (lexi))		   1; past CONST*
	   (list (make-operator-from-token '*constant-define* tok1)
		 (loop for con-d = (constant-definition)
		       and tok = (lexi)
		       when (not (eq (token-type tok) 'semi-colon))
		       do (parser-error "semi-colon expected after constant definition"
						'constant-definition-part tok)
		       collect (append-comment-to-last-operator con-d (token-comment tok))
		       while (eq (token-type (peek-at-token)) 'identifier))))))
  );1constant-definition-part


;;; the list of constants is returned, if the token OTHERS is found
;;; then the operator *OTHERWISE* is returned, possible this should be
;;; an option whether this should be allowed, for instance in variants maybe
;;; it should be disallowed
3(DEFUN CONSTANT-LIST ()**
  2"The production is: constant-list -> constant { ',' constant } .
Returns list of constants.  Token OTHERS is converted to operator *OTHERS*"*
;   (declare (function constant-list () (or operator list)))
   (if (eq (token-type (peek-at-token)) 'others)
       (make-operator-from-token '*otherwise* (lexi))
       (loop for cnst = (constant)
	     while (eq (token-type (peek-at-token)) 'comma)
	     collect (append-comment-to-last-operator cnst (token-comment (lexi)))
	     into cnst-list
	     finally (return (append cnst-list (list cnst)))))
  );1constant-list


3(DEFUN DIRECTIVE ()**
  2"The production: directive -> letter { letter | digit }"*
;   (declare (function directive () list))
   (let ((tok1 (peek-at-token)))
     (when (and (eq (token-type tok1) 'identifier)
		(member (get-id-name tok1) all-directives))
       (list (make-operator-from-token '*directive* (lexi))
	     (get-id-name tok1)))
     );1let*
  );1directive


3(DEFUN ENUMERATED-TYPE ()**
  2"The production is: enumerated-type -> '(' identifier-list ')' ."*
;   (declare (function enumerated-type () cons))
   (let ((tok1 (lexi))
	 tok2 id-list)
     (cond ((not (eq (token-type tok1) 'left-paren))
	    (parser-error "left parenthesis [(] expected" 'enumerated-type tok1)))
     (setf id-list (identifier-list))
     (cond ((not (eq (token-type (setf tok2 (lexi))) 'right-paren))
	    (parser-error "right parenthesis [)] expected" 'enumerated-type tok2)))
     (list (make-operator-from-token '*enumerated-type* tok1)
	   (append-comment-to-last-operator id-list
					    (token-comment tok2)))
     );1let*
  );1enumerated-type


3(DEFUN EXPRESSION ()**
  2"The production is: expression -> simple-expression [ relation-operator simple-expression ] ."*
  (let ((exp1 (simple-expression))
	rel-op)
    (if (setf rel-op (relation-operator))
	(list rel-op exp1 (simple-expression))
	exp1))
  );1expression


3(DEFUN FACTOR ()**
  2"The production is: factor -> variable-access | unsigned-constant | function-designator | set-constructor |
                                     '(' expression ')' | NOT factor .
Note: a function with no parameters, will be recognized as a variable-access, also a constant identifier,
these will be taken care of by code generator."*
  (let ((tok (peek-at-token))
	tok1 exp tok2)
    (case (token-type tok)
      (identifier			   1; could be a variable access or a function designator*
       (if (eq (token-type (peek-at-token 2)) 'left-paren)
	   (function-designator)
	   (variable-access)))
      
      ((int-const real-const string nilx)  1; is this an unsigned constant?*
       (unsigned-constant))
      
      (left-brck			   1; is this a set constructor?*
       (set-constructor))
      
      (left-paren			   1; is this a "(" expression ")" construct?*
       (setf tok1 (lexi))
       (setf exp (expression))
       (append-comment-to-last-operator (oper exp)                 1; put the "(" comment on the first operator*
					(token-comment tok1))	   1; of the expression*
       (cond ((not (eq (token-type (setf tok2 (lexi))) 'right-paren))
	      (parser-error "unbalanced parenthesis in" 'factor tok2)))
       (append-comment-to-last-operator exp (token-comment tok2)))
      
      (not				   1; is this NOT followed by factor*
       (list (make-operator-from-token '*not-op* (lexi))
	     (factor)))
      
      (t (parser-error "ill formed expression, in" 'factor tok)))
    );1let*
  );1factor


3(DEFUN FIELD-LIST ()**
  2"The production is: field-list -> [ ( fixed-part [ [';'] variant-part ] | variant-part ) [ ';' ] ] ."*
  (let (fix-prt var-prt)
    (cond ((eq (token-type (peek-at-token)) 'identifier)
	   (setf fix-prt (fixed-part))
	   (cond ((eq (token-type (peek-at-token)) 'semi-colon)
		  (append-comment-to-last-operator fix-prt (token-comment (lexi)))))
	   (cond ((eq (token-type (peek-at-token)) 'case)
		  (setf var-prt (variant-part))
		  (cond ((eq (token-type (peek-at-token)) 'semi-colon)
			 (append-comment-to-last-operator var-prt (token-comment (lexi))))))))
	  ((eq (token-type (peek-at-token)) 'case)
	   (setf var-prt (variant-part))
	   (when (eq (token-type (peek-at-token)) 'semi-colon)
	     (append-comment-to-last-operator var-prt (token-comment (lexi))))))
    (list fix-prt var-prt)
    );1let*
  );1field-list


3(DEFUN FILE-TYPE ()**
  2"The production is: file-type -> FILE OF type-denoter ."*
  (let ((tok1 (lexi))				1; should be FILE*
	(tok2 (lexi)))				1; should be OF*
    (cond ((not (eq (token-type tok1) 'file))
	   (parser-error "a FILE was expected at the beginning of" 'file-type tok1)))
    (cond ((not (eq (token-type tok2) 'of))
	   (parser-error "OF expected after keyword FILE" 'file-type tok2)))
    (list (append-comment-to-last-operator (make-operator-from-token
					     '*file-type* tok1)
					   (token-comment tok2))
	  (type-denoter))
    );1let*
  );1file-type


3(DEFUN FIXED-PART ()**
  2"The production is: fixed-part -> record-section { ';' record-section } ."*
  (loop for recs = (record-section)
	while (and (eq (token-type (peek-at-token)) 'semi-colon)
		   (eq (token-type (peek-at-token 2)) 'identifier))
	collect (append-comment-to-last-operator recs (token-comment (lexi)))
	    into rec-sect-list
	finally (return (append rec-sect-list (list recs))))
  );1fixed-part


3(DEFUN FOR-STATEMENT ()**
  2"The production is: for-statement -> FOR identifier ':=' expression ( TO | DOWNTO ) expression DO statement ."*
  (let ((tok1 (lexi))			1  ; this is a FOR*
	id tok2 exp1 tok3 op exp2 tok4)
    (cond ((not (eq (token-type tok1) 'for))
	   (parser-error "a FOR was expected at the beginning of" 'for-statement tok1)))
    (setf id (identifier 'for-statement))
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'assign))
	   (parser-error ":= was expected after control variable" 'for-statement tok2)))
    (setf exp1 (expression))
    (setf op
	  (make-operator-from-token
	    (cond ((eq (token-type (setf tok3 (lexi))) 'to) '*for-to-statement*)
		  ((eq (token-type tok3) 'downto) '*for-downto-statement*)
		  (t (parser-error "either DOWNTO or TO was expected after initial value"
				   'for-statement tok3)))
	    tok1))
    (setf exp2 (expression))
    (cond ((not (eq (token-type (setf tok4 (lexi))) 'do))
	   (parser-error "DO expected after final value" 'for-statement tok4)))
    (list op
	  (append-comment-to-last-operator id (token-comment tok2))
	  (append-comment-to-last-operator exp1 (token-comment tok3))
	  (append-comment-to-last-operator exp2 (token-comment tok4))
	  (statement)))
  );1for-statement


3(DEFUN FORMAL-PARAMETER-LIST ()**
  2"The production is: formal-parameter-list -> '(' formal-parameter-section { ';' formal-parameter-section } ')' ."*
  (let ((tok1 (lexi))
	first-fps)
    (cond ((not (eq (token-type tok1) 'left-paren))
	   (parser-error "left parenthesis expected at the beginning of" 'formal-parameter-list tok1)))
    (setf first-fps (formal-parameter-section))
    (append-comment-to-last-operator (oper first-fps)	1  ; the CAR this is the operator*
				     (token-comment tok1))
    (list (make-operator-from-token '*formal-parameters* tok1)
	  (loop for fps first first-fps then (formal-parameter-section)
		and tok = (lexi)
		do (append-comment-to-last-operator fps (token-comment tok))
		collect fps
		while (eq (token-type tok) 'semi-colon)
		finally (cond ((not (eq (token-type tok) 'right-paren))
			       (parser-error "right parenthesis expected at the end of"
						     'formal-parameter-list tok)))))
    );1let*
  );1format-parameter-list


3(DEFUN FORMAL-PARAMETER-SECTION ()**
  2"The production is: formal-parameter-section ->
value-parameter-specification | variable-parameter-specification | procedural-parameter-specification | functional-parameter-specification  ."*
  (let* ((tok (peek-at-token)))
    (case (token-type tok)
	  (identifier (value-parameter-specification))
	  (var        (variable-parameter-specification))
	  (procedure  (procedural-parameter-specification))
	  (function   (functional-parameter-specification))
	  (otherwise  (parser-error "expected to see a formal parameter specification"
				   'formal-parameter-section tok))
	  );1case*
    );1let**
  );1format-parameter-section


3(DEFUN FUNCTION-DECLARATION (&aux tok1 fun-head)**
  2"The production is: function-declaration -> function-heading ';' (directive | block ) | 'function' identifier ';' block .
Returns a function block, which is *FUNCTION* <id> <parameter-list> <return-type> and <body> if this is the block
of a forward declared function, then <parameter-list> and <return-type> are both NIL."*
  (cond ((and (eq (token-type (peek-at-token)) 'function)
	      (eq (token-type (peek-at-token 2)) 'identifier)
	      (eq (token-type (peek-at-token 3)) 'semi-colon))
	 (list (make-operator-from-token '*function* (lexi))
	       (append-comment-to-last-operator (make-operator-from-token '*identifier*
									  (lexi))
						(token-comment (lexi)))
	       nil nil
	       ($block)))
	(t (setf fun-head (function-heading))
	   (cond ((not (eq (token-type (setf tok1 (lexi))) 'semi-colon))
		  (parser-error "expected a semi-colon after function heading"
				'function-declaration tok1)))
	   (append (append-comment-to-last-operator fun-head (token-comment tok1))
		   (list (cond ((directive))
			       (t ($block)))))))
  );1function-declaration


3(DEFUN FUNCTION-DESIGNATOR ()**
  2"The production is: function-designator -> identifier [ actual-parameter-list ] ."*
  (let* ((tok0 (peek-at-token))
	 (fun-id (identifier 'function-designator)))
    (list (make-operator '*function-call* nil
			 (token-start tok0) (token-line-no tok0))
	  fun-id
	  (cond ((eq (token-type (peek-at-token)) 'left-paren)
		 (actual-parameter-list))
		(t nil))))
  );1function-designator


3(DEFUN FUNCTION-HEADING ()**
  2"The production is: function-heading -> FUNCTION identifier [ formal-parameter-list ] ':' identifier ."*
  (let ((tok1 (lexi))
	fun-id tok2 fpl)
    (cond ((not (eq (token-type tok1) 'function))
	   (parser-error "expected FUNCTION to at the beginning of" 'function-declaration tok1)))
    (setf fun-id (identifier 'function-heading))
    (cond ((eq (token-type (peek-at-token)) 'left-paren)
	   (setf fpl (formal-parameter-list))))
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'colon))
	   (parser-error "expected a colon before the result type" 'function-heading tok2)))
    (list (make-operator-from-token '*function* tok1)
	  fun-id
	  fpl
	  (identifier 'function-heading)))
  );1function-heading


3(DEFUN FUNCTIONAL-PARAMETER-SPECIFICATION ()**
  2"The production is: functional-parameter-specification -> function-heading ."*
  (let ((fun-head (function-heading)))
    (setf (op-name (oper fun-head)) '*functional-parameter*)
    fun-head)
  );1functional-parameter-specification


3(DEFUN GOTO-STATEMENT ()**
  2"The production is: goto-statement -> GOTO label ."*
  (let ((tok1 (lexi))
	tok2 lab)
    (if (not (eq (token-type tok1) 'goto))
	(parser-error "expected a GOTO" 'goto-statement tok1))
    (cond ((not (setf lab (label(setf tok2 (lexi)))))
	   (parser-error "expected a proper label in" 'goto-statement tok2)))
    (list (make-operator-from-token '*goto-statement* tok1)
	  lab))
  );1goto-statement


3(DEFUN IDENTIFIER (&optional (fun nil))**
   2"If FUN is supplied and this is not an identifier, then an error message is printed saying an identifier was expected in FUN"*
;   (declare (function identifier (&optional symbol) list)
;	    (values identifier-list))
  (let ((tok1 (peek-at-token)))
    (cond ((not (eq (token-type tok1) 'identifier))
	   (if fun
	       (parser-error "expected an identifier" fun tok1)
	       nil))
	  (t (list (make-operator-from-token '*identifier* (setf tok1 (lexi)))
		   (get-id-name tok1)))))
  );1identifier


3(DEFUN IDENTIFIER-LIST ()**
  2"The production is: identifier-list -> identifier { ',' identifier } ."*
   (declare (values list-of-identifiers))
  (loop for id = (identifier 'identifier-list)
	while (eq (token-type (peek-at-token)) 'comma)
	collect (append-comment-to-last-operator id (token-comment (lexi)))
	into id-list
	finally (return (append id-list (list id))))
  );1identifier-list


3(DEFUN IF-STATEMENT ()**
  2"The production is: if-statement -> IF expression THEN statement [ ELSE statement ] ."*
  (let ((tok1 (lexi))			1  ; this should be IF*
	tok2 exp stmt1 tok3 stmt2)
    (cond ((not (eq (token-type tok1) 'if))
	   (parser-error "expected an IF before the boolean expression" 'if-statement tok1)))
    (setf exp (expression))
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'then))
	   (parser-error "expected a THEN after the boolean expression" 'if-statement tok2)))
    (setf stmt1 (statement))
    (append-comment-to-last-operator stmt1 (token-comment tok2))
    (append (list (make-operator-from-token '*if-statement* tok1)
		  exp
		  stmt1)
	    (cond ((eq (token-type (peek-at-token)) 'else)
		   (setf tok3 (lexi))
		   (setf stmt2 (statement))
		   (list (append-comment-to-last-operator stmt2 (token-comment tok3))))
		  (t nil))))
  );1if-statement


3(DEFUN LABEL (lab)**
  "2returns a *LABEL* operator followed by the label is LAB is legal"*
  (and (eq (token-type lab) 'int-const)
       (<= 0 (get-constant lab))
       (>= 9999 (get-constant lab))
       (list (make-operator-from-token '*label* lab)
	     (get-constant lab)))
  );1label


3(DEFUN LABEL-DECLARATION-PART ()**
  2"The production is: label-declaration-part -> [ LABEL label { ',' label } ';' ] .
The list with the *LABEL-DECLARE* operator followed by a list of labels is returned."*
  (let ((ty (token-type (peek-at-token))) tok1)
    (cond ((eq ty 'label)
	   (setf tok1 (lexi))			; consume LABEL
	   (loop for lab = (label (lexi))
		 and tok = (lexi)
		 when (null lab)
		 do (parser-error "expected a label (a digit sequence in [0..9999]) in"
					  'label-declaration-part tok)
		 do (append-comment-to-last-operator (oper lab) (token-comment tok)) 
		 collect lab into label-list
		 until (not (eq (token-type tok) 'comma))
		 finally (cond ((not (eq (token-type tok) 'semi-colon))
				      (parser-error "expected a SEMI-COLON (;) after the last label"
							    'label-declaration-part tok))
			       (t (return (list (make-operator-from-token '*label-declare* tok1)
						label-list))))))
	  (t nil)))
  );1label-declaration-part


3(DEFUN MEMBER-DESIGNATOR ()**
  2"The production is: member-designator -> expression [ '..' expression ] .
Returns either just the expression if there is no range indicator, or (<expression1> <expression2>) if there is a range indicator"*
  (let ((exp1 (expression)))
    (cond ((eq (token-type (peek-at-token)) 'dot-dot)
	   (list (append-comment-to-last-operator exp1
						  (token-comment (lexi)))
		 (expression)))
	  (t exp1)))
  );1member-designator


3(DEFUN MULTIPLYING-OPERATOR ()**
  2"The production is: multiplying-operator  '*' | '/' | DIV | MOD | AND ."*
  (get-operator multiplying-operator-alist))


3(DEFUN NEW-ORDINAL-TYPE ()*
  2"The production is: new-ordinal-type -> enumerated-type | subrange-type ."*
  (cond ((eq (token-type (peek-at-token)) 'left-paren)
	 (enumerated-type))
	(t (subrange-type)))
  );1new-ordinal-type


3(DEFUN NEW-POINTER-TYPE ()**
  2"The production is: new-pointer-type -> '^' identifier ."*
  (let ((tok1 (lexi)))
    (cond ((not (eq (token-type tok1) 'up-arrow))
	   (parser-error "expected an up arrow (^)" 'new-pointer-type tok1)))
    (list (make-operator-from-token '*pointer-type* tok1)
	  (identifier 'new-pointer-type)))
  );1new-pointer-type


3(DEFUN NEW-STRUCTURED-TYPE ()**
  2"The production is: new-structured-type -> [ PACKED ] unpacked-structured-type ."*
  (cond ((eq (token-type (peek-at-token)) 'packed)
	 (list (make-operator-from-token '*packed* (lexi))
	       (unpacked-structured-type)))
	(t (unpacked-structured-type)))
  );1new-structured-type


3(DEFUN NEW-TYPE ()**
  2"The production is: new-type -> new-ordinal-type | new-structured-type | new-pointer-type ."*
  (let ((ty (token-type (peek-at-token))))
    (cond ((or (eq ty 'identifier) (eq ty 'left-paren)
	       (eq ty 'plus) (eq ty 'minus)
	       (eq ty 'string) (eq ty 'int-const)
	       (eq ty 'real-const))
	   (new-ordinal-type))
	  ((or (eq ty 'packed) (eq ty 'array) (eq ty 'file)
	       (eq ty 'record) (eq ty 'set))
	   (new-structured-type))
	  ((eq ty 'up-arrow)
	   (new-pointer-type))))
  );1new-type


3(DEFUN ORDINAL-TYPE ()**
  2"The production is: ordinal-type -> new-ordinal-type | identifier ."*
  (let ((tok1 (peek-at-token))
	(tok2 (peek-at-token 2)))
    (cond ((and (eq (token-type tok1) 'identifier)
		(not (eq (token-type tok2) 'dot-dot)))
	   (identifier 'ordinal-type))
	  (t (new-ordinal-type))))
  );1ordinal-type


3(DEFUN PROCEDURAL-PARAMETER-SPECIFICATION ()**
  2"The production is: procedural-parameter-specification -> procedure-heading ."*
  (let ((proc-head (procedure-heading)))
    (setf (op-name (oper proc-head)) '*procedural-parameter*)
    proc-head))


3(DEFUN PROCEDURE-AND-FUNCTION-DECLARATION-PART ()*
  2"The production is: procedure-and-function-declaration-part -> { ( procedure-declaration | function-declaration ) ';' } ."*
  (loop with tok1 and decl
	for tok = (peek-at-token)
	while (member (token-type tok) '(function procedure))
	do (setf decl (case (token-type tok)
			(procedure (procedure-declaration))
			(function (function-declaration))))
	when (not (eq (token-type (setf tok1 (lexi))) 'semi-colon))
	do (parser-error
	     "a SEMI-COLON (;) was expected after a procedure or function definition"
	     'procedure-and-function-declaration-part tok1)
	collect (append-comment-to-last-operator decl (token-comment tok1)))
  );1procedure-and-function-declaration-part


3(DEFUN PROCEDURE-DECLARATION ()**
  2"The production is: procedure-declaration -> procedure-heading ';' ( directive | block ) ."*
  (let ((proc-head (procedure-heading))
	tok1)
    (cond ((not (eq (token-type (setf tok1 (lexi))) 'semi-colon))
	   (parser-error "a SEMI-COLON (;) was expected after the procedure heading"
				 'procedure-declaration tok1)))
    (append (append-comment-to-last-operator proc-head (token-comment tok1))
	    (list (cond ((directive))
			(t ($block))))))
  );1procedure-declaration


3(DEFUN PROCEDURE-HEADING ()**
  2"The production is: procedure-heading -> PROCEDURE identifier [ formal-parameter-list ] ."*
  (let ((tok1 (lexi)) id)
    (cond ((not (eq (token-type tok1) 'procedure))
	   (parser-error "expected PROCEDURE at the beginning of" 'procedure-declaration tok1)))
      (cons (make-operator-from-token '*procedure* tok1)
	    (cons (setf id (identifier 'procedure-heading))
		  (cond ((eq (token-type (peek-at-token)) 'left-paren)
			 (list (formal-parameter-list)))
			(t (list nil))))))
  );1procedure-heading


3(DEFUN PROCEDURE-STATEMENT ()**
  2"The production is: procedure-statement -> procedure-identifier [ actual-parameter-list ] ."*
  (let* ((tok0 (peek-at-token))
	 (proc-id (identifier)))
    (list (make-operator '*procedure-call* nil
			 (token-start tok0) (token-line-no tok0))
	  proc-id
	  (cond ((eq (token-type (peek-at-token)) 'left-paren)
		 (actual-parameter-list))
		(t nil))))
  );1procedure-statement


;;; Note ala DEC-20 pascal, identifiers in the program header can have additional
;;; attributes on them, (after a colon), for know only the attribute "/" is recognized
;;; this only applies to the file parameter INPUT.  It inhibits an initial implicit
;;; GET from the terminal
3(DEFUN PROGRAM-PARAMETERS (&aux tok2)**
  (append-comment-to-last-operator
    (loop for id = (identifier 'program-parameters)
	  do (setf tok2 (lexi))
	  when (eq (token-type tok2) 'colon)
	  do1 ;; This is a directive, ignore all but /*
	  (loop until (not (member (token-type (peek-at-token)) '(plus minus star slash)))
		for tok3 = (lexi)
		when (eq (token-type tok3) 'slash)
		do (setf id (list (append-comment-to-last-operator
				    (make-operator-from-token '*no-implicit-get* tok3)
				    (token-comment tok2)) id))
		else do (format *LOG-STREAM* "The attribute ~C is not implemented, it is ignored"
				(case (token-type tok3)
				  (plus #\+) (minus #\-) (star #\*)))
		finally (setf tok2 (lexi)))
	  collect (append-comment-to-last-operator id (token-comment tok2))
	  while (eq (token-type tok2) 'comma)
	  finally (cond ((not (eq (token-type tok2) 'right-paren))
			 (parser-error
			   "a right parenthesis [)] was expected after the identifier list"
			   'program-parameters tok2))))
    (token-comment tok2))
   );1program-parameters


3(DEFUN PROGRAM ()**
  2"The production is: program -> 'program' identifier [ '(' identifier-list ')' ] ';' block '.' ."*
  (let* ((tok1 (lexi))
	 program-id
	 tok3
	 id-list
	 blck
	 tok4)
    (cond ((not (eq (token-type tok1) 'program))
	   (parser-error "expected PROGRAM as the first token to be read in" 'program tok1)))
    (setf program-id (identifier 'program))
    (cond ((eq (token-type (peek-at-token)) 'left-paren)
	   (append-comment-to-last-operator program-id (token-comment (lexi)))
	   (setf id-list (program-parameters))))
    (cond ((not (eq (token-type (setf tok3 (lexi))) 'semi-colon))
	   (parser-error "a SEMI-COLON (;) was expected after the program header in" 'program tok3)))
    (append-comment-to-last-operator id-list (token-comment tok3))
    (setf blck ($block))
    (cond ((not (eq (token-type (setf tok4 (lexi))) 'period))
	   (parser-error "a PERIOD (.) was expected after final END in" 'program tok4)))
    (append-comment-to-last-operator blck (token-comment tok4))
    (list (make-operator-from-token '*program* tok1)
	  program-id id-list blck)
    );1let**
  );1program


3(DEFUN RECORD-SECTION ()**
  2"The production is: record-section -> identifier-list ':' type-denoter ."*
  (let ((id-list (identifier-list))
	tok1)
    (cond ((not (eq (token-type (setf tok1 (lexi))) 'colon))
	   (parser-error "expected a COLON (:) after the identifier list" 'record-section tok1)))
    (list (append-comment-to-last-operator id-list (token-comment tok1))
	  (type-denoter)))
  );1record-selection


3(DEFUN RECORD-TYPE ()**
  2"The production is: record-type -> RECORD field-list END ."*
  (let ((tok1 (lexi))			   1; should be RECORD*
	field-l tok2)
    (cond ((not (eq (token-type tok1) 'record))
	   (parser-error "expected a RECORD at the beginning of" 'record-type tok1)))
    (setf field-l (field-list))
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'end))
	   (parser-error "expected an END at the end of" 'record-type tok2)))
    (list (make-operator-from-token '*record-type* tok1)
	  (append-comment-to-last-operator field-l (token-comment tok1))))
  );1record-type


3(DEFUN RECORD-VARIABLE-LIST ()**
  2"The production is: record-variable-list -> record-variable { ',' record-variable } .
The list of record-variables is returned."*
   (declare (values list-of-record-variables))
   (loop for vara = (variable-access)
	 while (eq (token-type (peek-at-token)) 'comma)
	 collect (append-comment-to-last-operator vara (token-comment (lexi)))
	 into vara-list
	 finally (return (append vara-list (list vara))))
   );1record-variable-list


3(DEFUN RELATION-OPERATOR ()**
  2"The production is: relation-operator -> '=' | '<>' | '<' | '>' | '<=' | '>=' | IN ."*
  (get-operator relation-operator-alist))


3(DEFUN REPEAT-STATEMENT ()*
  2"The production is: repeat-statement -> REPEAT statement-sequence UNTIL expression ."*
  (let ((tok1 (lexi))			   1; should be REPEAT*
	tok2 stmt-seq)
    (cond ((not (eq (token-type tok1) 'repeat))
	   (parser-error "expected an REPEAT at the beginning of" 'repeat-statement tok1)))
    (setf stmt-seq (statement-sequence))
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'until))
	   (parser-error "expected an UNTIL to close" 'repeat-statement tok2)))
    (list (make-operator-from-token '*repeat-statement* tok1)
	  (append-comment-to-last-operator stmt-seq (token-comment tok2))
	  (expression)))
  );1repeat-statement


3(DEFUN REPETITIVE-STATEMENT ()**
  (let ((ty (token-type (peek-at-token))))
    (cond ((eq ty 'repeat) (repeat-statement))
	  ((eq ty 'while) (while-statement))
	  ((eq ty 'for) (for-statement))))
   );1repetitive-statement


3(DEFUN SET-CONSTRUCTOR ()**
  2"The production is: set-constructor -> '[' [ member-designator { ',' member-designator } ] ']' ."*
  (let ((tok1 (lexi)) member-deses)
    (cond ((not (eq (token-type tok1) 'left-brck))
	   (parser-error "expected a left bracket ([) in the beginning of" 'set-constructor tok1)))
    (setf member-deses
	  (if (not (eq (token-type (peek-at-token)) 'right-brck))
	      (loop for memd = (member-designator)
		    for tok = (lexi)
		    collect (append-comment-to-last-operator memd (token-comment tok))
		    while (eq (token-type tok) 'comma)
		    finally
		    (cond ((not (member (token-type tok) '(comma right-brck)))
			   (parser-error "expected a right bracket (]) at the end of"
					 'set-constructor tok))))
	      nil))
    (if member-deses
	(list (make-operator-from-token '*set-constructor* tok1)
	      member-deses)
	(list (append-comment-to-last-operator
		(make-operator-from-token '*set-constructor* tok1)
		(token-comment (lexi)))
	      nil)))
  );1set-constructor


3(DEFUN SET-TYPE ()**
  2"The production is: set-type -> SET OF ordinal-type ."*
  (let ((tok1 (lexi))			   1; should be SET*
	(tok2 (lexi)))			   1; should be OF*
    (cond ((not (eq (token-type tok1) 'set))
	   (parser-error "expected SET in the beginning of" 'set-type tok1)))
    (cond ((not (eq (token-type tok2) 'of))
	   (parser-error "expected OF after SET"
				 'set-type tok2)))
    (list (append-comment-to-last-operator (make-operator-from-token '*set-type* tok1)
					   (token-comment tok2))
	  (ordinal-type)))
  );1set-type


3(DEFUN SIGN ()**
  2"The production is: sign -> '+' | '-' .
Returns either NIL, or one of the operators *UNARY-PLUS* or *UNARY-MINUS*."*
  (get-operator sign-alist))


3(DEFUN SIGNED-INTEGER ()*
  2"The production is: signed-integer -> [ sign ] unsigned-integer ."*
  (let (tok1)
    (multiple-value-bind (si si-comment)
	(sign)
      (setf si (or si 1))
      (cond ((not (eq (token-type (setf tok1 (lexi))) 'int-const))
	     (parser-error "expected a number" 'signed-integer tok1)))
      (values (* si (get-constant tok1))
	      (string-append si-comment (token-comment tok1)))))
  );1signed-integer


3(DEFUN SIMPLE-EXPRESSION ()**
  2"The production is: simple-expression -> [ sign ] term { adding-operator term } ."*
  (let ((si (sign)))
    (loop with result = (cond (si (list si (term)))
			      (t (term)))
	  for add-op = (adding-operator)  ; ADDING-OPERATOR returns a token or NIL
	  while add-op
	  for this-term = (term)
	  do (setf result (list add-op result this-term))
	  finally (return result)))
  );1simple-expression


3(DEFUN SIMPLE-STATEMENT ()**
  2"The production is: simple-statement -> empty-statement | assignment-statement | procedure-statement | goto-statement ."*
  (let* ((tok1 (peek-at-token))
	 (ty (token-type tok1)))
    (cond ((member ty '(semi-colon end until))  ; process an empty statement
	   (list (make-operator '*empty-statement* nil
				(token-start tok1) (token-line-no tok1))))
	  ((eq ty 'identifier)
	   (cond ((member (token-type (peek-at-token 2)) '(assign period left-brck up-arrow))
		  (assignment-statement))
		 (t (procedure-statement))))
	  ((eq ty 'goto)
	   (goto-statement))
	  (t (parser-error "expected IDENTIFIER, SEMICOLON or GOTO at the beginning of"
				   'simple-statement tok1))))
  );1simple-statement


3(DEFUN STATEMENT ()**
  2"The production is: statement -> [ label ':' ] ( simple-statement | structured-statement ) ."*
  (let ((tok1 (peek-at-token))
	tok2 lab)
    (cond ((setf lab (label tok1))
	   (lexi)				; consume label
	   (cond ((not (eq (token-type (setf tok2 (lexi))) 'colon))
		  (parser-error "expected a COLON (:) after a label," 'statement tok2))
		 (t (setf tok1 (peek-at-token))))
	   (append-comment-to-last-operator lab (token-comment tok2))))
    (list lab
	  (cond ((member (token-type tok1) '(begin if case repeat while for with))
		 (structured-statement))
		(t (simple-statement)))))
  );1statement


3(DEFUN STATEMENT-PART ()**
  2"The production is: statement-part -> compound-statement ."*
  (compound-statement))


3(DEFUN STATEMENT-SEQUENCE ()*
  2"The production is: statement-sequence -> statement { ';' statement } ."*
  (loop	for stmt = (statement)
	and tok1 = (peek-at-token)
	collect (if (eq (token-type tok1) 'semi-colon)
		    (append-comment-to-last-operator stmt
						     (token-comment (lexi)))
		    stmt)
	while (eq (token-type tok1) 'semi-colon))
  );1statement-sequence


3(DEFUN STRUCTURED-STATEMENT ()**
  2"The production is: structured-statement -> compound-statement | conditional-statement |
                                                        repetitive-statement | with-statement"*
  (let* ((tok1-typ (token-type (peek-at-token))))
    (cond ((eq tok1-typ 'begin)
	   (compound-statement))
	  ;; do conditional statements
	  ((or (eq tok1-typ 'if) (eq tok1-typ 'case))
	   (conditional-statement))
	  ;; do reptitive statements
	  ((or (eq tok1-typ 'repeat) (eq tok1-typ 'while) (eq tok1-typ 'for))
	   (repetitive-statement))
	  ;; do a WITH statement
	  ((eq tok1-typ 'with)
	   (with-statement))))
  );1structured-statement


3(DEFUN SUBRANGE-TYPE ()**
  2"The production is: subrange-type -> constant '..' constant ."*
  (let ((first (constant))
	tok1)
    (unless (eq (token-type (setf tok1 (lexi))) 'dot-dot)
      (parser-error "a range indicator (..) was expected after a constant was found" 'subrange-type tok1))
    (list (make-operator-from-token '*subrange-type* tok1)
	  first (constant)))
  );1subrange-type


3(DEFUN TERM ()**
  2"The production is: term -> factor { multiplying-operator factor } ."*
    (loop with result = (factor)
	  for mul-op = (multiplying-operator)	   1; MULTIPLYING-OPERATOR returns a token or NIL*
	  while mul-op
	  for this-factor = (factor)
	  do (setf result (list mul-op result this-factor))
	  finally (return result))
    );1term


3(DEFUN TYPE-DEFINITION ()**
  2"The production is: type-definition -> identifier '=' type-denoter ."*
   (declare (values type-definition))
  (let ((id (identifier 'type-definition))
	tok2)
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'equal))
	   (parser-error "expected an equal sign (=)" 'type-definition tok2)))
    (list (append-comment-to-last-operator id (token-comment tok2))
	  (type-denoter)))
  );1type-definition


3(DEFUN TYPE-DEFINITION-PART ()**
  2"The production is: type-definition-part -> [ TYPE type-definition ';' { type-definition ';' } ] ."*
   (declare (values type-declaration-prefix-section))
  (let ((ty (token-type (peek-at-token))))
    (cond ((eq ty 'type)
	   (list (make-operator-from-token '*type-define* (lexi))
		 (loop collect (type-definition) into list-of-type-definitions
		       for semi-tok = (lexi)
		       when (not (eq (token-type semi-tok) 'semi-colon))
		       do (parser-error "expected a semi-colon after a type definition in"
						'type-definition-part semi-tok)
		       do (append-comment-to-last-operator list-of-type-definitions
							   (token-comment semi-tok))
		       while (eq (token-type (peek-at-token)) 'identifier)
		       finally (return list-of-type-definitions))))))
  );1type-definition-aprt


3(DEFUN TYPE-DENOTER ()**
  2"The production is: type-denoter -> identifier | new-type ."*
  (cond ((and (eq (token-type (peek-at-token)) 'identifier)
	      (not (eq (token-type (peek-at-token 2)) 'dot-dot)))
	 (identifier))
	(t (new-type)))
  );1type-denoter


3(DEFUN UNPACKED-STRUCTURED-TYPE (&aux (tok1 (peek-at-token)))**
  2"The production is: unpacked-structured-type -> array-type | record-type | set-type | file-type ."
1   ;; The first token in each production is used here to determine the production.**
  (case (token-type tok1)
    (array ($array-type))
    (record (record-type))
    (set (set-type))
    (file (file-type))
    (otherwise (parser-error "expected one of ARRAY, RECORD, SET or FILE"
				     'unpacked-structured-type tok1)))
  );1unpacked-structure-type


3(DEFUN UNSIGNED-CONSTANT ()**
  2"The production is: unsigned-constant -> unsigned-number | character-string | constant-identifier | NIL ."*
  (let ((ty (token-type (peek-at-token)))
	tok1)
    (cond ((or (eq ty 'int-const) (eq ty 'real-const))
	   (list (make-operator-from-token '*number* (setf tok1 (lexi)))
		 (get-constant tok1)))
	  ((eq ty 'string)
	   (list (make-operator-from-token '*string* (setf tok1 (lexi)))
		 (get-string tok1)))
	  ((eq ty 'identifier) (identifier))
	  ((eq ty 'nilx)
	   (list (make-operator-from-token '*nil-x* (setf tok1 (lexi)))))))
  );1unsigned-constant


3(DEFUN VALUE-PARAMETER-SPECIFICATION ()**
  2"The production is: value-parameter-specification -> identifier-list ':' identifier ."*
  (let* ((id-list (identifier-list))
	 (tok1 (lexi)))
    (cond ((not (eq (token-type tok1) 'colon))
	   (parser-error "expected a COLON (:) after the identifier list"
				 'value-parameter-specification tok1)))
    (list (append-comment-to-last-operator id-list (token-comment tok1))
	  (identifier 'value-parameter-specification)))
  );1value-parameter-specification


3(DEFUN VARIABLE-ACCESS ()**
  2"The production is: variable-access -> identifier { accessor } ."*
  (loop with acc = (identifier 'variable-access)
	while (member (token-type (peek-at-token)) '(left-brck period up-arrow))
	do (setf acc (accessor acc))
	finally (return acc))
  );1variable-access


3(DEFUN VARIABLE-DECLARATION ()**
  2"The production is: variable-declaration -> identifier-list ':' type-denoter ."*
   (declare (values variable-declaration))
  (let ((id-list (identifier-list))
	tok1)
    (cond ((not (eq (token-type (setf tok1 (lexi))) 'colon))
	   (parser-error "expected a COLON (:) after the identifier list" 'variable-declaration tok1)))
    (list (append-comment-to-last-operator id-list (token-comment tok1))
	  (type-denoter)))
  );1variable-declaration


3(DEFUN VARIABLE-DECLARATION-PART ()**
  2"The production is: variable-declaration-part -> [ VAR variable-declaration ';'{ variable-declaration ';' } ] ."*
   (declare (values variable-declaration-prefix-part))
  (let ((ty (token-type (peek-at-token))))
    (cond ((eq ty 'var)
	   (list (make-operator-from-token '*variable-declare* (lexi))
		 (loop collect (variable-declaration) into list-of-variable-declarations
		       for semi-tok = (lexi)
		       when (not (eq (token-type semi-tok) 'semi-colon))
		       do (parser-error "expected a semi-colon after a variable declaration"
						'variable-declaration-part semi-tok)
		       do (append-comment-to-last-operator list-of-variable-declarations
							   (token-comment semi-tok))
		       while (eq (token-type (peek-at-token)) 'identifier)
		       finally (return list-of-variable-declarations))))
	  (t nil))
    );1let*
  );1variable-declaration-part


3(DEFUN VARIABLE-PARAMETER-SPECIFICATION ()**
  2"The production is: variable-parameter-specification -> VAR identifier-list ':' type-identifier ."*
  (let* ((tok1 (lexi))					; should be VAR
	 id-list tok2)
    (cond ((not (eq (token-type tok1) 'var))
	   (parser-error "expected a VAR at the beginning of" 'variable-parameter-specification tok1)))
    (setf id-list (identifier-list))
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'colon))
	   (parser-error "expected a COLON (:) after the identifier list"
			 'variable-parameter-specification tok2)))  
    (list (make-operator-from-token '*variable-parameter* tok1)
	  (append-comment-to-last-operator id-list (token-comment tok2))
	  (identifier 'variable-parameter-specification))
    );1let**
  );1variable-parameter-secification


3(DEFUN VARIANT ()**
  2"The production is: variant -> constant-list ':' '(' field-list ')' ."*
  (let* ((const-l (constant-list))
	 (tok1 (lexi))
	 fie-l tok2 tok3)
    (cond ((not (eq (token-type tok1) 'colon))
	   (parser-error "expected a COLON (:) after the constant list" 'variant tok1)))
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'left-paren))
	   (parser-error "expected a LEFT PARENTHESIS after the COLON" 'variant tok2)))
    (append-comment-to-last-operator
      (append-comment-to-last-operator const-l
				       (token-comment tok1))
      (token-comment tok2))
    (setf fie-l (field-list))
    (cond ((not (eq (token-type (setf tok3 (lexi))) 'right-paren))
	   (parser-error "expected a RIGHT PARENTHESIS after the field list" 'variant tok3)))
    (list const-l (append-comment-to-last-operator fie-l (token-comment tok3))))
  );1variant


3(DEFUN VARIANT-PART ()**
  2"The production is: variant-part -> CASE variant-selector OF variant { ';' variant } ."*
  (let ((tok1 (lexi))			   1; should be CASE*
	tag tok2)
    (cond ((not (eq (token-type tok1) 'case))
	   (parser-error "expected a CASE at the beginning of" 'variant-part tok1)))
    (setf tag (variant-selector))
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'of))
	   (parser-error "expected an OF after the variant-selector" 'variant-part tok2)))
    (list (make-operator-from-token '*variant-part* tok1)
	  (append-comment-to-last-operator tag (token-comment tok2))
	  (loop for vara = (variant)
		and tok1 = (peek-at-token)
		and tok2 = (peek-at-token 2)
		while (and (eq (token-type tok1) 'semi-colon)
			   (not (eq (token-type tok2) 'end)))
		collect (append-comment-to-last-operator vara (token-comment (lexi)))
		into vara-list
		finally (return (append vara-list (list vara)))))
1      *);1let*
  );1variant-part


3(DEFUN VARIANT-SELECTOR ()**
  2"The production is: variant-selector -> [ identifier ':' ] identifier ."*
  (let* ((tag-field (identifier 'variant-selector))
	 (tok1 (peek-at-token)))
    (cond ((eq (token-type tok1) 'colon)
	   (lexi)
	   (list (append-comment-to-last-operator tag-field
					     (token-comment tok1))
		 (identifier 'variant-selector)))
	  (t tag-field)))
  );1variant-selector


3(DEFUN WHILE-STATEMENT ()**
  2"The production is: while-statement -> WHILE expression DO statement ."*
  (let ((tok1 (lexi))			   1; this should be WHILE*
	tok2 exp)
    (cond ((not (eq (token-type tok1) 'while))
	   (parser-error "a WHILE is needed before the expression" 'while-statement tok1)))
    (setf exp (expression))
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'do))
	   (parser-error "a DO is needed after the expression" 'while-statement tok2)))
    (list (make-operator-from-token '*while-statement* tok1)
	  (append-comment-to-last-operator exp (token-comment tok2))
	  (statement)))
  );1while-statement


3(DEFUN WITH-STATEMENT ()**
  2"The production is: with-statement -> WITH record-variable-list DO statement ."*
  (let ((tok1 (lexi))			   1; this is a WITH*
	tok2 rcvl)
    (cond ((not (eq (token-type tok1) 'with))
	   (parser-error "a WITH is needed before the record var list" 'with-statement tok1)))
    (setf rcvl (record-variable-list))
    (cond ((not (eq (token-type (setf tok2 (lexi))) 'do))
	   (parser-error "a DO is needed after the record var list" 'with-statement tok2)))
    (list (make-operator-from-token '*with-statement* tok1)
	  (append-comment-to-last-operator rcvl
					   (token-comment tok2))
	  (statement)))
  );1with-statement