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

1;;;; GENERATES THE SYMBOL TABLE



3(DEFUN ENTER-ARRAYS (id prefix packed?)**
  2"enter an array type into symbol table"*
  (if (not (eq (op-name (oper prefix)) '*array-type*))
      (error-handler 'enter-arrays
		     "expected *ARRAY-TYPE* in the beginning of an array definition in"))
  (let* ((index (gen-ordinal-type (arg1 prefix)))
	 (type-of-array (gen-type-denoter nil (arg2 prefix) packed?)))
    (cond ((not (eq (op-name (oper prefix)) '*array-type*))
	   (error-handler 'enter-arrays "expected *ARRAY-TYPE* in the beginning of")))
    (insert-symtab (arg1 id) :type :array
		   :packed packed?
		   :index-type index
		   :type-of-array type-of-array))
  );1enter-arrays


3(DEFUN ENTER-CONSTANTS (prefix)**
    (cond ((not (null prefix))
	   (mapcar #'(lambda (prefix)
		     (if (not (eq (op-name (oper (first prefix))) '*identifier*))
			 (error-handler 'enter-constants
					"expected an identifier at the beginning of constant definition, in"))
		     (insert-symtab (arg1 (first prefix))
				    :const
				    :value (get-constant-value (second prefix))))
		   (arg1 prefix)))
	  (t nil))
   );1enter-constants


3(DEFUN GET-CONSTANT-VALUE (prefix &aux info)**
   2"gets the constant value out of the constant of a constant definition"*
  (case (op-name (oper prefix))
    ((*number* *string*) (arg1 prefix))
    (*identifier* (if (enumerated (setf info (lookup-symtab (arg1 prefix))))
		      (pascal-id info)
		      (value info)))
    ((*unary-minus* *unary-plus*)
     (if (not (or (eq (op-name (oper (arg1 prefix))) '*number*)
		  (and (eq (op-name (oper (arg1 prefix))) '*identifier*)
		       (not (enumerated (setf info
					      (lookup-symtab (arg1 (arg1 prefix)))))))))
	 (error-handler 'get-constant-value
			"trying to do an illegal operation ~:[+~;-~] on ~A at line number ~D in"
			(eq (op-name (oper prefix)) '*unary-minus*)
			(arg1 prefix) (op-line-no (oper prefix))))
     (* (if (eq (op-name (oper prefix)) '*unary-minus*) -1 1)
	(if (eq (op-name (oper (arg1 prefix))) '*identifier*)
	    (value info)
	    (arg1 (arg1 prefix))))))
  );1get-constant-value


3(DEFUN ENTER-ENUMERATED (id prefix)**
  (if (not (eq (op-name (oper prefix)) '*enumerated-type*))
      (error-handler 'enter-enumerated
		     "expected *ENUMERATED-TYPE* in the beginning of type definition in"))
  (insert-symtab (arg1 id) :type :enumerated
		 (mapcar #'(lambda (x) (arg1 x)) (arg1 prefix)))
  );1enter-enumerated


3(DEFUN ENTER-FIELD-LIST (id prefix &optional (packed? nil))**
  (multiple-value-bind (fields do-not-need-array) (symtab-gen-field-list prefix packed?)
    (insert-symtab (if (null id)
		       (arg1 (get-new-anon-id t))
		       (arg1 id))
		   :type :record
		   :fields fields
		   :do-not-need-array do-not-need-array
		   :packed packed?))
   );1enter-field-list


3(DEFUN SYMTAB-GEN-FIELD-LIST (prefix &optional (packed? nil) &aux fix-prt (do-not-need-array 0))**
  2"Generate the field list of a record type"*
  (cond ((not (null (first prefix)))
	 (setf fix-prt
	       (loop with info
		     for rec-sect in (first prefix)
		     for type-id = (gen-type-denoter nil (second rec-sect))
		     when (and do-not-need-array packed?)
		     do (cond ((typep (setf info (lookup-symtab type-id))
				      'symtab-record-type)
			       (cond ((do-not-need-array info)
				      (incf do-not-need-array (do-not-need-array info)))))
			      ((typep info 'symtab-subrange-type)
			       (incf do-not-need-array (get-bit-size-of-subrange info)))
			      ((or (typep info 'symtab-array-type)
				   (> do-not-need-array 0))
			       (setf do-not-need-array nil))
			      (t (setf do-not-need-array 32)))
		     collect (cons (mapcar #'(lambda (field-id) (arg1 field-id)) (first rec-sect))
				   type-id)))))
  (multiple-value-bind (tag-f var-prt num-of-bits)
      (symtab-gen-variant-part (second prefix) packed?)
    (if (or fix-prt tag-f var-prt)
	(values (make-field-list fix-prt tag-f var-prt)
		(if (or (null packed?) (null num-of-bits) (null do-not-need-array)
			(> (+ do-not-need-array num-of-bits) 32))
		    nil
		    (+ do-not-need-array num-of-bits)))
	(values nil 0)))
  );1symtab-gen-field-list


3(DEFUN ENTER-FILES (id prefix packed? &aux (num-of-bits nil) component-type ct-info)**
  2"enter into symbol table a file type."*
  (cond-every ((not (eq (op-name (oper prefix)) '*file-type*))
	       (error-handler 'enter-files
			      "expected *FILE-TYPE* in the beginning of type definition in"))
	      ((not (eq (op-name (oper id)) '*identifier*))
	       (error-handler 'enter-files
			      "expected *IDENTIFIER* as the first thing in")))
  (setf component-type (gen-type-denoter nil (arg1 prefix)))
  (when packed?
    (CASE (TYPEP (SETF ct-info (lookup-symtab component-type)))
	  (primitive-type
	   (WHEN (EQ (required-type ct-info) :integer)
	     (SETF num-of-bits 32.)))
	  (symtab-subrange-type
	   (when
	       (AND (numberp (smallest ct-info))
		    (numberp (largest ct-info)))
	     (setf num-of-bits
		   (get-bit-size-of-subrange
				   ct-info))))
	  (symtab-record-type
	   (SETF num-of-bits (do-not-need-array ct-info)))))
  (insert-symtab (arg1 id) :type :file
		 :component-type component-type
		 :packed packed?
		 :num-of-bits num-of-bits)
  );1enter-files


3(DEFMACRO SYMTAB-GEN-VALUE-PARAMETERS (prefix)**
  2"generate an alist associating the parameters and their types"*
  `(symtab-gen-var-or-value-parms (first ,prefix) (second ,prefix) 'value))


3(DEFMACRO SYMTAB-GEN-VARIABLE-PARAMETERS (prefix)*
  2"generate an alist associating the parameters and their types"*
  `(symtab-gen-var-or-value-parms (arg1 ,prefix) (arg2 ,prefix) 'var))


3(DEFUN SYMTAB-GEN-VAR-OR-VALUE-PARMS (id-list type-id var-or-value)*
  2"generate an alist associating the parameters and their types"*
  (mapcar #'(lambda (id)
	    (list (arg1 id) var-or-value (arg1 type-id)))
	  id-list))


3(DEFUN SYMTAB-GEN-FORMAL-PARAMETERS (prefix)*
  2"return a formal parameter list to be entered into the symbol table"*
  (cond ((not (null prefix))
	 (cond ((not (eq (op-name (oper prefix)) '*formal-parameters*))
		(error-handler 'symtab-gen-formal-parameters
			       "expected *FORMAL-PARAMETERS* at line number ~D in"
			       (op-line-no (oper prefix)))))
	 (mapcan #'(lambda (form-parm-sect)
		   (cond ((consp (oper form-parm-sect))
			  (symtab-gen-value-parameters form-parm-sect))
			 ((eq (op-name (oper form-parm-sect)) '*variable-parameter*)
			  (symtab-gen-variable-parameters form-parm-sect))
			 ((eq (op-name (oper form-parm-sect)) '*procedural-parameter*)
			  (list (list (arg1 (arg1 form-parm-sect)) 'procedure)))
			 ((eq (op-name (oper form-parm-sect)) '*functional-parameter*)
			  (list (list (arg1 (arg1 form-parm-sect)) 'function)))))
		 (arg1 prefix))))
  );1symtab-gen-formal-parameters


3(DEFUN ENTER-FORMAL-PARAMETERS (prefix)**
   2"first mark the a new level in the symbol table and then enter the var and value parameters"*
  (cond ((not (null prefix))
	 (cond ((not (eq (op-name (oper prefix)) '*formal-parameters*))
		(error-handler 'enter-formal-parameters
			       "expected *FORMAL-PARAMETERS* at line number ~D in"
			       (op-line-no (oper prefix)))))
	 (loop for parm-spec in (arg1 prefix)
	       do (cond ((consp (oper parm-spec))
			 (loop with sym-type = (second parm-spec)
			       for parm in (first parm-spec)
			       do (insert-symtab (arg1 parm) :var :parameter 'value (arg1 sym-type))))
			((eq (op-name (oper parm-spec)) '*variable-parameter*)
			 (loop with sym-type = (arg2 parm-spec)
			       for parm in (arg1 parm-spec)
			       do (insert-symtab (arg1 parm) :var :parameter 'var (arg1 sym-type))))
			((eq (op-name (oper parm-spec)) '*procedural-parameter*)
			 (enter-procedures parm-spec t))
			((eq (op-name (oper parm-spec)) '*functional-parameter*)
			 (enter-functions parm-spec t))
			(t (error-handler 'enter-formal-parameters "illegal parameter type in"))))))
  );1enter-formal-parameters


3(DEFUN ENTER-FUNCTIONS (prefix &optional (parameter nil))**
  2"enter the information about the function into the symbol table, return the function's PASCAL name"*
   1;; if there is no return ID and already something in the symbol table,*
   1;; don't enter this, it is already forward declared*
  (cond ((not (and (null (arg3 prefix))
		   (not (null (lookup-symtab (arg1 (arg1 prefix))
					     *CURRENT-LEVEL*)))))
	 (insert-symtab (arg1 (arg1 prefix))
			:function :parameter (and parameter 'function)
			:parms (symtab-gen-formal-parameters (arg2 prefix))
			:returns (arg1 (arg3 prefix))))
	(t (push (arg1 (arg1 prefix)) *CURRENT-DEFINITION-STACK*)
	   (lookup-symtab (arg1 (arg1 prefix)))))
  );1enter-functions*

;1;; ++ mod by pso & sjp mapcar=>mapc and number test *7/02/86 16:01:59
3(DEFUN ENTER-LABELS (prefix)*
  2"enter the labels into the symbol table"*
  (cond ((not (null prefix))
	 (if (not (eq (op-name (oper prefix)) '*label-declare*))
	     (error-handler 'enter-labels
			    "expected a *LABEL-DECLARE* at the beginning of label declarations section in"))
	 (mapc #'(lambda (lab)
		   (insert-symtab
		       (arg1 lab)
		       :label))
	       (arg1 prefix)))
	(t nil))
  );1enter-labels


3(DEFUN ENTER-NEW-TYPE (id prefix)**
  2"enter a new type into the symbol table"*
  (case (op-name (oper prefix))
    (*enumerated-type* (enter-enumerated id prefix))
    (*subrange-type* (enter-subranges id prefix))
    (*pointer-type* (enter-pointers id prefix))
    (*packed* (enter-unpacked-structureds id (arg1 prefix) t))
    ((*array-type* *record-type* *file-type* *set-type*)
     (enter-unpacked-structureds id prefix nil))
    (*identifier* (insert-symtab (arg1 id) :type (arg1 prefix))))
  );1enter-new-type


3(DEFUN ENTER-POINTERS (id prefix)**
  2"enter a new pointer type into the symbol table"*
  (if (or (not (eq (op-name (oper prefix)) '*pointer-type*))
	  (not (eq (op-name (oper id)) '*identifier*))
	  (not (eq (op-name (oper (arg1 prefix))) '*identifier*)))
      (error-handler 'enter-pointers
		     "illegal format of ID or PREFIX in"))
  (insert-symtab (arg1 id)
		 :type :pointer (arg1 (arg1 prefix)))
  );1enter-pointers


3(DEFUN ENTER-PROCEDURES (prefix &optional (parameter nil))**
  2"enter the information about the procedure into the symbol table, return the procedure's PASCAL name"*
   1;; check if this procedure is already defined, if so and there are no parameters then*
   1;; just return the name, as this procedure was forward declared. [we assume]*
  (cond ((not (null (lookup-symtab (arg1 (arg1 prefix)) *CURRENT-LEVEL*)))
	 (cond ((not (null (arg2 prefix)))
		(error-handler 'enter-procedures
			       "a forward declared procedure had a parameter list, at line number ~D"
			       (op-line-no (oper prefix))))
	       (t (push (arg1 (arg1 prefix)) *CURRENT-DEFINITION-STACK*)
		  (lookup-symtab (arg1 (arg1 prefix))))))
	(t (insert-symtab (arg1 (arg1 prefix))
			  :procedure :parameter (and parameter 'procedure)
			  :parms (symtab-gen-formal-parameters (arg2 prefix)))))
  );1enter-procedures


3(DEFUN ENTER-RECORDS (id prefix packed?)**
  2"enter a record type into the symbol table"*
  (cond ((not (eq (op-name (oper prefix)) '*record-type*))
	 (error-handler 'enter-records
			"expected a *RECORD-TYPE* at the beginning of")))
  (enter-field-list id (arg1 prefix) packed?)
  );1enter-records


3(DEFUN ENTER-SETS (id prefix packed?)**
  2"enter into symbol table a set type."*
  (cond-every ((not (eq (op-name (oper prefix)) '*set-type*))
	       (error-handler 'gen-sets
			      "expected *SET-TYPE* in the beginning of type definition in"))
	      ((not (eq (op-name (oper id)) '*identifier*))
	       (error-handler 'gen-sets
			      "expected *IDENTIFIER* as the first thing in")))
  (insert-symtab (arg1 id) :type :set
		 :base-type (gen-type-denoter nil (arg1 prefix))
		 :packed packed?)
  );1enter-sets


3(DEFUN ENTER-SUBRANGES (id prefix)**
  2"enter a new subrange type into the symbol table"*
  (let* ((smallest (get-constant-value (arg1 prefix)))
	 (largest (get-constant-value (arg2 prefix)))
	 (host-type (find-subrange-constant-type smallest)))
    (if (not (eq host-type (find-subrange-constant-type largest)))
	(error-handler 'enter-subrange-type
		       "different types in a subrange type in"))
    (insert-symtab (arg1 id)
		   :type :subrange
		   :range smallest largest
		   :host-type host-type))
  );1enter-subranges


3(DEFUN ENTER-UNPACKED-STRUCTUREDS (id prefix packed?)**
  2"choose the right structured type to generate: array, record, set, file."*
  (case (op-name (oper prefix))
    (*array-type* (enter-arrays id prefix packed?))
    (*record-type* (enter-records id prefix packed?))
    (*set-type* (enter-sets id prefix packed?))
    (*file-type* (enter-files id prefix packed?))
    (otherwise (error-handler 'unpacked-structureds
			      "expected one of *ARRAY-TYPE*, *RECORD-TYPE*, *SET-TYPE*~
                               or *FILE-TYPE*, but found ~A" (op-name (oper prefix)))))
  );1enter-unpacked-structures


3(DEFUN ENTER-VARIABLES (prefix &aux type-id)**
  2"enter variable declarations into symbol table if any"*
  (cond ((not (null prefix))
	 (if (not (eq (op-name (oper prefix)) '*variable-declare*))
	     (error-handler 'gen-variable-declarations "expected *VARIABLE-DECLARE* in"))
	 (mapcar #'(lambda (var-decl)
		   (setf type-id (gen-type-denoter nil (second var-decl)))
		   (loop for var in (first var-decl)
			 do (insert-symtab (arg1 var) :var type-id)))
		 (arg1 prefix)))
	(t nil))
  );1enter-variables


3(DEFUN SYMTAB-GEN-VARIANT-PART (prefix &optional (packed? nil))**
  2"generate a variant part if there is one."*
   (declare (values tag-field variant-fields-list))
  (let ((do-not-need-array 0)
	tag-field var-fields)
    (cond ((and (not (null prefix))
		(eq (op-name (oper prefix)) '*variant-part*))
	   (setf tag-field (if (consp (first (arg1 prefix)))
			       (cons (arg1 (first (arg1 prefix)))
				     (arg1 (second (arg1 prefix))))
			       (cons (arg1 (get-new-anon-id))
				     (arg1 (arg1 prefix))))
		 var-fields 
		 (mapcar #'(lambda (pre)
			   (cons (mapcar #'get-constant-value (first pre))
				 (multiple-value-bind (type num-of-bits)
				     (symtab-gen-field-list (second pre) packed?)
				   (if (not (null do-not-need-array))
				       (setf do-not-need-array (and num-of-bits
								    (max num-of-bits
									 do-not-need-array))))
				   type)))
			 (arg2 prefix)))
	   (values tag-field var-fields do-not-need-array))
	  (t (values nil nil 0))))
  );1symtab-gen-variant-part