;;; -*- Mode: COMMON-LISP; PACKAGE: PASCALX; Fonts:(MEDFNT1 *HL12b HL12I MEDFNB); Base: 10 -*-

1;;; These are the symbol table routines for the PASCAL parser.*


;1;; COMPILE-TIME CONSTANTS DEFINITIONS
3(DEFCONSTANT BIGGEST-CHARACTER**   (dotimes (code char-code-limit char-code-limit)
				       (when (graphic-char-p (code-char (- char-code-limit code 1)))
					 (return (code-char (- char-code-limit code 1))))))

3(DEFCONSTANT SMALLEST-CHARACTER*  (dotimes (code char-code-limit 0)
				       (when (graphic-char-p (code-char code))
					 (return (code-char code)))))
3(DEFCONSTANT ALL-MAIN-TYPES*      '(:LABEL :CONST :TYPE :VAR :PROCEDURE :FUNCTION :PROGRAM)
  2"All the possible main types for an identifier"*)

3(DEFCONSTANT ALL-SUB-TYPES* '(:PRIMITIVE :ENUMERATED :SUBRANGE :POINTER :ARRAY :RECORD :SET :FILE)
  2"the allowed TYPES in PASCAL"*)

3(DEFVAR *SYMTAB** (let ((DEFAULT-CONS-AREA *PASCALX-STATIC-AREA*))
		     (make-hash-table :test #'eq :size 1000))
   2"the actual symbol table"*)

1;;; Note that level refers to the number of nesting of procedures or functions.
3(DEFVAR *LEVEL-LIST*** NIL 2"holds list of symbol defined on this level"*)

3(DEFVAR *ALL-OTHER-LEVEL-LISTS** NIL
  2"holds the lists of all symbols defined on all previous levels,"*)

3(DEFMACRO PARM-TYPE (name-type)*
   "2returns parameter type from NAME-TYPE pair"*
   `(cadr ,name-type))

3(DEFVAR *PATH-SUFFIX* ""*
  2"the suffix to append at the end of a variable name to uniquely identify each variable"*)


3(DEFCONSTANT PRE-DEFINED-IDS*  `((BOOLEAN :TYPE :PRIMITIVE :BOOLEAN)
				   (CHAR    :TYPE :PRIMITIVE :CHAR)
				   (INTEGER :TYPE :PRIMITIVE :INTEGER)
				   (REAL    :TYPE :PRIMITIVE :REAL)
				   (TEXT    :TYPE :FILE :COMPONENT-TYPE CHAR)
				   (ABS     :FUNCTION :PARMS ((X VALUE REAL)) :RETURNS *TYPE-OF-ARGUMENTS*)
				   (ARCTAN  :FUNCTION :PARMS ((X VALUE REAL)) :RETURNS REAL)
					   ;1; ++ Added break to accept stream*
				   (BREAK   :PROCEDURE :PARMS ((F VAR :ANY)))
				   (BREAKIN :PROCEDURE :PARMS
					    ((F VAR :ANY) (B VALUE :BOOLEAN)))
				   (CHR     :FUNCTION :PARMS ((X VALUE INTEGER)) :RETURNS CHAR)
				   (CLOSE   :PROCEDURE :PARMS ((F VAR :ANY)))	   1; file F, non-standard, closes stream*
				   (COS     :FUNCTION :PARMS ((X VALUE REAL)) :RETURNS REAL)
				   (DATE    :FUNCTION :PARMS NIL :RETURNS INTEGER)
				   (DISPOSE :PROCEDURE :PARMS :NLAM)
				   (EOF     :FUNCTION :PARMS ((F VAR :ANY)) :RETURNS BOOLEAN)	   1; F is a file*
				   (EOLN    :FUNCTION :PARMS ((F VAR TEXT)) :RETURNS BOOLEAN)	   1; F is a file*
					   ;1; ++ ADDED ERSTAT *
				   (ERSTAT  :FUNCTION :PARMS ((F VAR :ANY)) :RETURNS BOOLEAN)
				   (EVEN    :FUNCTION :PARMS ((X VALUE INTEGER)) :RETURNS BOOLEAN)
				   (EXP     :FUNCTION :PARMS ((X VALUE REAL)) :RETURNS REAL)
				   (FALSE   :CONST :VALUE 0 :PART-OF-TYPE BOOLEAN)
				   (FILEEXISTSP :FUNCTION :PARMS ((F VAR :ANY)) :RETURNS BOOLEAN)  1; F is a file*
				   (GET     :PROCEDURE :PARMS ((F VAR :ANY)))	   1; F is a file*
				   (INPUT   :VAR TEXT)
				   (LN      :FUNCTION :PARMS ((X VALUE REAL)) :RETURNS REAL)
				   (MAXINT  :CONST :VALUE ,MOST-POSITIVE-FIXNUM)
				   (NEW     :PROCEDURE :PARMS :NLAM)	   1; P is a pointer*
				   (ODD     :FUNCTION :PARMS ((X VALUE INTEGER)) :RETURNS BOOLEAN)
				   (ORD     :FUNCTION :PARMS ((X VALUE :ANY)) :RETURNS INTEGER)
				   (OUTPUT  :VAR TEXT)
				   (PACK    :PROCEDURE :PARMS
					    ((A VAR :ANY)  1; A is an array, I,J indices*
					     (I VALUE :ANY)
					     (Z VAR :ANY)))
				   (PAGE    :PROCEDURE :PARMS ((F VAR :ANY)))	   1; F is a file*
				   (PRED    :FUNCTION  :PARMS ((X VALUE :ANY)) :RETURNS *TYPE-OF-ARGUMENTS*)
				   (PUT     :PROCEDURE :PARMS ((F VAR :ANY)))	   1; F is a file*
				   (READ    :PROCEDURE :PARMS :NLAM)
				   (READLN  :PROCEDURE :PARMS :NLAM)
				   (RESET   :PROCEDURE :PARMS ((F VAR :ANY)))	   1; F is a file*
				   (REWRITE :PROCEDURE :PARMS ((F VAR :ANY)))	   1; F is a file*
				   (ROUND   :FUNCTION :PARMS ((X VALUE REAL)) :RETURNS INTEGER)
				   (SIN     :FUNCTION :PARMS ((X VALUE REAL)) :RETURNS REAL)
				   (SQR     :FUNCTION :PARMS ((X VALUE REAL)) :RETURNS *TYPE-OF-ARGUMENTS*)
				   (SQRT    :FUNCTION :PARMS ((X VALUE REAL)) :RETURNS REAL)
				   (SUCC    :FUNCTION :PARMS ((X VALUE :ANY)) :RETURNS *TYPE-OF-ARGUMENTS*)
				   (TIME    :FUNCTION :PARMS NIL :RETURNS INTEGER)
				   (TRUE    :CONST :VALUE 1 :PART-OF-TYPE BOOLEAN)
				   (TRUNC   :FUNCTION :PARMS ((X VALUE REAL)) :RETURNS INTEGER)
				   (UNPACK  :PROCEDURE :PARMS
					    ((Z VAR :ANY)  1; A is an array, I,J indices*
					     (I VALUE :ANY)
					     (J VAR :ANY)))
				   (WRITE   :PROCEDURE :PARMS :NLAM)
				   (WRITELN :PROCEDURE :PARMS :NLAM))
  2"The predefined identifiers and their types. :ANY matches any type.  :NLAM matches any number of types."*
  );1predefined-ids


3(DEFUN GET-NEW-ANON-ID (&optional variantp)**
   "2returns a new identifier with *ANON*- or *VARIANT*- prefix depending upon VARIANTP"*
   (declare (values identifier))
  (list (make-operator '*identifier* nil 0 0)
	(gentemp (if variantp "*VARIANT*-" "*ANON*-"))))


3(DEFUN INIT-SYMTAB ()*
  2"Does the symbol table initialization"*
   (declare (values t))
   (clrhash *SYMTAB*)
   (setf *ALL-OTHER-LEVEL-LISTS* ()
	 *LEVEL-LIST* ()
	 *PATH-SUFFIX* ""
	 *CURRENT-LEVEL* -1
	 *SET-OF-GLOBAL-SYMBOLS-USED* ()
	 *SETS-OF-SYMBOLS-USED-BY-OTHER-LEVELS* () )
   (dolist (id-attrib-list PRE-DEFINED-IDS)
     1;; Insert the predefined identifiers*
     (apply #'insert-symtab
	    (first id-attrib-list)
	    (REST id-attrib-list)))
  (setf (access-form (lookup-symtab 'writeln)) (access-form (lookup-symtab 'pascalx:write)))
  t);1init-symtab


3(DEFUN CHECK-ID-OK (id** pkg3)*
   "2If ID is reserved [e.g., T], then return a unique symbol. Else, return ID."*
   (declare (values unique-symbol))
   (when-type-checking
     (check-type id symbol))
;1;; ++ wrote better check to see if symbol is special.*
   (MULTIPLE-VALUE-BIND (nid ignore apkg) (INTERN (STRING id) pkg)
     (if    
	 (not (equal (pkg-name apkg)
		     (STRING pkg)))
	 ;1; then ID is a reserved symbol, so generate an alternate*
	 (gentemp id pkg)
	 ;1; else ID is OK, so use it as-is*
	 ;1; ++ Have to (string id) because, for some strange reason, intern*
	1  *;1; returns wrong value.*
	 nid))
   );1check-id-ok*

;1; ++ added :variable *7/09/86 16:31:48
3(DEFUN GET-ID-STRING (id att old-entry)*
  2"returns the form that will be the name of this id"*
   (declare (values print-identifier))
   (let ((new-id (if (not (null old-entry))
		     ;1; then there is an old entry, so prepend ID to suffix*
		     (intern (concatenate 'string (string id) *PATH-SUFFIX*))
		     ;1; else there is no old entry, so just use ID*
		     (intern id)))
	 (pkg *output-package*))
     (cond ((and (= *CURRENT-LEVEL* -1)
	      (member (car att)
		      '(:function
			 :procedure :const :var)))
	    	    (setq pkg 'pascalx)))

    (make-print-identifier :name (check-id-ok new-id pkg)
			   :package pkg)
    );1let*
  );1get-id-string


3(DEFMACRO GET-FUN-NAME (prefix symname)**
  `(make-print-identifier :name (intern (concatenate 'STRING
						     ,prefix (STRING (pid-name ,symname))))
			  :package *OUTPUT-PACKAGE*))

;1;; ++ added (or symbol number) *7/09/86 16:40:50
3(DEFUN INSERT-SYMTAB (id &rest att)*
  2"inserts ID into the symbol table and returns entry"*
   (when-type-checking
     (check-type id (OR symbol number)))
   (IF (TYPEP id 'number)
       (SETQ id (make-label-into-symbol id))) 
 (let* ( (old-entry (GETHASH (INTERN (STRING-DOWNCASE id)
				     'pascalx) *SYMTAB*))
	 (old (or old-entry (make-symtab-entry)))
	 (new nil)
	 (sym-name (typecase  id
		     (cons    id)
;		     (number  (get-id-string (make-label-into-symbol id) att old-entry))
		     (otherwise (get-id-string id att
					       old-entry))))
	 (keep-old-p (when (not (or (null (current old))
				    (not (eq (pid-name (access-form (car (current old))))
					     (pid-name sym-name)))))
		       (if *DEBUG-CODE-GEN-P*
			   ;1; then since we are debugging interactively, give the user the option to redefine it*
			   (y-or-n-p "~%There are multiple definitions of the variable ~A.~
                                      ~%Do you want to keep the old one?" id)

			1    *;1; else we are no debugging, so just report it and keep the old one*
			   (progn
			     (format *LOG-STREAM* "~%Multiple Definition for the variable ~A~%" id)
			     t)
			   );1if*
		       );1when*
		     ))

    (if keep-old-p
	;1; then keep the old one*
	(car (current old))

	;1; else replace old with the new one*
	(progn
	  (push id *LEVEL-LIST*)
	  (setf new old)
	  (push (extract-symbol-table-entry id sym-name att) (current new))
	  (setf (pascal-id (car (current new))) id)
	  (car (current (setf (GETHASH (INTERN (STRING-DOWNCASE id)
				     'pascalx) *SYMTAB*) new) )))
	);1if*
    );1let**
  );1insert-symtab


3(DEFUN EXTRACT-SUB-TYPE (id sym-name sub-type att &aux option pack)**
   "2returns sub-type infornation of type identifier"*
  (ignore option)
  (case sub-type
    (:enumerated (let ((count 0))
		   (make-symtab-enumerated-type	   1; insert the enumerated ids into the symbol table*
		     :poss-values (mapcar #'(lambda (x)
					   (prog1
					     (pascal-id (insert-symtab x :const :value count :part-of-type id))
					     (incf count)))
					 (car att)))))
    (:subrange (let (host-type smallest largest ht-info)
		 (keyword-extract att option () ()
				  (:range (setf smallest (cadr option))
				   (setf largest (car (setf option (cddr option)))))
				  (:host-type (setf host-type (car (setf option
									 (cdr option))))))
		 (setf ht-info (lookup-symtab host-type))
		 (make-symtab-subrange-type :host-type host-type
					    :smallest smallest
					    :largest largest
					    :init-function (init-function ht-info)
					    :assign-function (assign-function ht-info))))
    (:pointer (make-symtab-pointer-type :symtab-domain-type (car att)))
    (:array (let (ty ind)
	      (keyword-extract att option ((:type-of-array ty) (:index-type ind)
					   (:packed pack)))
	      (make-symtab-array-type :type-of-array ty
				      :array-index-type ind
				      :init-function (get-fun-name "*MAKE*-" sym-name)
				      :packed pack
				      :array-accessor (get-fun-name  "*ACCESS*-" sym-name))))
    (:record (let (fields do-not-need-array)
	       (keyword-extract att option (fields do-not-need-array (:packed pack)))
	       (make-symtab-record-type :init-function (get-fun-name "*MAKE*-" sym-name)
					:field-accessor-prefix
					(concatenate 'STRING
						     (STRING  (pid-name sym-name)) ".")
					:record-fields fields
					:do-not-need-array do-not-need-array
					:packed pack)))
    (:set (let (base-type)
	    (keyword-extract att option (base-type (:packed pack)))
	    (make-symtab-set-type :symtab-base-type base-type
				  :packed pack)))
    (:file (let (component-type num-of-bits)
	     (keyword-extract att option (component-type  num-of-bits (:packed pack)))
	     (make-symtab-file-type :symtab-component-type component-type
				    :packed pack
				    :num-of-bits num-of-bits)))
    (:primitive (let ((in-fun (case (car att)
				(:char '*init-character*)
				(:boolean '*init-enumerated*)
				((:integer :real)
				 '*init-numeric*))))
		  (make-primitive-type :required-type (car att)
				       :init-function (make-print-identifier :name in-fun
									     :package 'pascalx))))
    (otherwise				   1; this should just be a type identifier, copy the info*
     (copy-symtab-entry (lookup-symtab sub-type))))
  );1extract-sub-type


;;; EXTRACT-SYMBOL-TABLE-ENTRY makes a symbol table type entry out of the attributes ATT.
;;; a type entry is a structure with NAME, MAIN-TYPE, PRE-DEFINED and LEVEL as its attributes,
;;; as well as other information depending on the type.  EXTRACT-SYMBOL-TABLE-ENTRY extracts
;;; the keywords to form a proper type. The type entry is returned.
;;; ATT has the form: <main-type> <other-attributes>
;;;     notes: if <main-type> is :TYPE the next thing has to be the SUB-TYPE of the symbol,
;;;            i.e. one of ALL-SUB-TYPES
;;;            a symbol is predefined if it's level is -1.
3(DEFUN EXTRACT-SYMBOL-TABLE-ENTRY (id sym-name att**
				   &aux entry m-type option)
  2"makes a symbol table type entry out of ATT"*
   (declare (values symbol-table-entry))
  (ignore option)
  (when (null (member (car att) all-main-types))
    (cerror "Proceed with no action."
	    "Illegal type given to INSERT-SYMTAB.  The options are: ~A" att))
  (setf entry (case (setf m-type (pop att))
		(:label (make-label))
		(:const (let (val part)
			  (keyword-extract att option
					   ((:value val) (:part-of-type part)))
			  (make-const :value val
				      :part-of-type part
				      :access-form (if (and (not (null part)) (not (eq part 'boolean)))
						      (list 'quote sym-name)))))
		(:type (cond ((not (or (member (car att) all-sub-types)
				       (typep (lookup-symtab (car att)) 'type)))
			      (cerror "Proceed with no action."
				      "Illegal SUB type given to INSERT-SYMTAB.  The options are: ~A" att))
			     (t (extract-sub-type id sym-name (pop att) att))))
		(:var (loop with temp = (make-var)
			    for option on att
			    do (case (car option)
				 (:parameter (setf (parameter temp) (car (setf option (cdr option)))))
				 (:with-variable-form (setf (access-form temp)	1  ; this is a with variable*
							    (car (setf option (cdr option)))))
				 (otherwise (setf (var-type temp) (car option))))
			    finally (return temp)))
		((:function :procedure :program)
		 (setf sym-name (check-function-name sym-name))
		 (let (parameter parms returns)
		   (keyword-extract att option (parameter parms returns))
		   (when (and returns (not (eq m-type :function)))
		     (warn (format nil "EXTRACT-SYMBOL-TABLE-ENTRY:  ~
                                        Tried to make a procedure or program have a :RETURNS attribute")))
		   (when (and parameter (eq m-type :program))
		     (warn (format nil "EXTRACT-SYMBOL-TABLE-ENTRY:  ~
                                        Tried to make a program have be a PARAMETER")))
		   (if (and (not (= *CURRENT-LEVEL* -1)) (not parameter))
		       (push id *CURRENT-DEFINITION-STACK*))
		   (case m-type
		     (:function (make-function :parameter parameter
					       :parms parms
					       :returns returns))
		     (:procedure (make-procedure :parameter parameter :parms parms))
		     (:program (make-program :prog-parms parms)))))))
  (if (not (access-form entry))
      (setf (access-form entry) sym-name))
  (setf (level entry) *CURRENT-LEVEL*)
  entry);1extract-symbol-table-entry


3(DEFUN COPY-SYMTAB-ENTRY (entry &aux temp)**
   "2returns copy of ENTRY with PASCAL-ID and ACCESS-FORM slots NIL"*
   (declare (values modified-entry))
  (setf temp 
	(case (type-of entry)		1  ; note, now only types have defined copier function*
	  (symtab-enumerated-type (copy-symtab-enumerated-type entry))
	  (symtab-subrange-type (copy-symtab-subrange-type entry))
	  (symtab-pointer-type (copy-symtab-pointer-type entry))
	  (symtab-array-type (copy-symtab-array-type entry))
	  (symtab-record-type (copy-symtab-record-type entry))
	  (symtab-set-type (copy-symtab-set-type entry))
	  (symtab-file-type (copy-symtab-file-type entry))
	  (primitive-type (copy-primitive-type entry))
	  ))
  (setf (pascal-id temp)   nil)
  (setf (access-form temp) nil)
  temp);1copy-symtab-entry


3(DEFUN FIND-SUBRANGE-CONSTANT-TYPE (value &aux info)**
   (declare (values type-symbol))
   (etypecase value
     (string (if (= (length value) 1)
		 'char
		 (warn "Illegal subrange constant in2 *FIND-SUBRANGE-CONSTANT-TYPE")))
     (symbol (or (part-of-type (setf info (lookup-symtab value)))
		 (find-subrange-constant-type (value info))))
     (integer 'integer)
     (real 'real)
     );1etypecase*
   );1find-subrange-constant-type


3(DEFUN LOOKUP-SYMTAB (id &optional (lev nil))**
  2"looks up ID in the symbol table and returns its attributes"*
   (declare (values attributes))
   (when-type-checking
     (check-type id (OR symbol number))
     (check-type lev (or null (integer -1 *))))
   (IF (NUMBERP id)
       (SETQ id (make-label-into-symbol id)))	   ;1++ return*
						1    *;1symbol for #*
  (let* ((info (GETHASH (INTERN (STRING-DOWNCASE id)
				     'pascalx) *SYMTAB*))
	 (most-recent (and info (car (current info)))))
    (cond ((null most-recent) nil)
	  ((not (null lev))		1; only return the information about the*
	   (and (not (null info))	1; most recently defined identifier, if LEV is supplied*
		(= lev (level most-recent)) most-recent))
	  (t most-recent)))
  );1lookup-symtab


3(DEFUN MAKE-SYMBOL-SPECIAL (sym-info &aux cur-fun-info)**
   2"MAKE-SYMBOL-SPECIAL if SYM-INFO (which is a symbol table record) is not on the current* 2level, then if it is a variable,
it is added to *SET-OF-GLOBAL-SYMBOLS-USED*, it is* 2also put in to the set in *SETS-OF-SYMBOLS-USED-BY-OTHER-LEVELS*
corresponding to the* 2level ID is defined on.  if it is a label then it is added to the *EXTERNAL-LABELS-USED** 2field of the
function or procedure currently being defined."*
  (cond ((eql (level sym-info) *CURRENT-LEVEL*))
	((typep sym-info 'label)
	 (setf cur-fun-info (lookup-symtab (car *CURRENT-DEFINITION-STACK*)))
	 (if (not (member (pascal-id sym-info) (external-labels-used cur-fun-info)))
	     (push (pascal-id sym-info) (external-labels-used cur-fun-info))))
	((typep sym-info 'var)
	 (setf *SET-OF-GLOBAL-SYMBOLS-USED*
	       (union (list (pascal-id sym-info)) *SET-OF-GLOBAL-SYMBOLS-USED*))
	 (cond ((and (not (pre-defined sym-info))
		     (not (member (pascal-id sym-info)
				(nth (- *current-level* (level sym-info))
				     *SETS-OF-SYMBOLS-USED-BY-OTHER-LEVELS*))))
		(push (pascal-id sym-info)
		      (nth (- *current-level* (level sym-info))
			   *SETS-OF-SYMBOLS-USED-BY-OTHER-LEVELS*)))
	       ((and (pre-defined sym-info)
		     (not (member (pascal-id sym-info)
				(car (last *SETS-OF-SYMBOLS-USED-BY-OTHER-LEVELS*)))))
		(push (pascal-id sym-info) (car (last *SETS-OF-SYMBOLS-USED-BY-OTHER-LEVELS*))))))
	(t (warn "MAKE-SYMBOL-SPECIAL:  Trying to make a non label or symbol (~A) be special."
		    (pascal-id sym-info))))
   );1make-symbol-special


3(DEFUN INHERIT-LABELS-USED (labels proc-name)**
  2"make PROC-NAME inherit all of LABELS that are not used by other levels"*
   (when-type-checking
     (check-type labels list)
     (check-type proc-name symbol))
  (let ((info (lookup-symtab proc-name)))
    (loop for lab in labels
	  when (< (level (lookup-symtab lab)) *CURRENT-LEVEL*)
	  do (setf (external-labels-used info)
		   (union (external-labels-used info) (list lab)))))
  );1inherit-labels-used


;;; MARK-SYMTAB marks a new level, it adds one to the level, initializes the list of identifiers
;;; defined at this level.  It also appends STR (if provided) to the path suffix.  And increments
;;; *CURRENT-LEVEL* if INCREMENT-CURRENT-LEVEL is T or left out.
3(DEFUN MARK-SYMTAB (&optional str (increment-current-level t))**
  2"marks a new level beginning"*
   (when-type-checking
     (check-type str (or null string)))
  (push *LEVEL-LIST* *ALL-OTHER-LEVEL-LISTS*)
  (setf *LEVEL-LIST* nil)
  (cond (increment-current-level
	 (incf *CURRENT-LEVEL*)
	 (push nil *SETS-OF-SYMBOLS-USED-BY-OTHER-LEVELS*)))
  (when (not (null str))
    (setf *PATH-SUFFIX* (concatenate 'string *PATH-SUFFIX* "-" str)))
  );1mark-symtab


;;; FREE-SYMTAB deletes all symbol defined at this level.  If FINISHED-WITH-THIS-LEVEL is
;;; omitted or T then the *PATH-SUFFIX* is updated and *CURRENT-LEVEL* decremented.
3(DEFUN FREE-SYMTAB (&optional (finished-with-this-level t))**
  2"deletes symbol from the current level"*
  (if (and *DEBUG-SYMTAB-P* (>= *CURRENT-LEVEL* 0)
	   (y-or-n-p "Want a symbol table dump "))
      (dump-symtab))
  1;; go down the list that is the car of *LEVEL-LIST* and remove that info from SYMTAB*
  (loop for id in *LEVEL-LIST*
	for value = (GETHASH (INTERN (STRING-DOWNCASE id)
				     'pascalx) *SYMTAB*) 
	do  (push (pop (current value)) (discarded value))
	    (setf (GETHASH (INTERN (STRING-DOWNCASE id)
				     'pascalx) *SYMTAB*) value)
	    );1loop*
  (setf *LEVEL-LIST* (pop *ALL-OTHER-LEVEL-LISTS*))
  (if finished-with-this-level
      (let ((p (position #\- *PATH-SUFFIX* :from-end t :end (1- (length *PATH-SUFFIX*)))))
	(setf *PATH-SUFFIX* (cond ((null p) "")
				(t (subseq *PATH-SUFFIX* 0 p))))
	(decf *CURRENT-LEVEL*)
	(pop *CURRENT-DEFINITION-STACK*)
	(setf *SET-OF-GLOBAL-SYMBOLS-USED* ())
	(pop *SETS-OF-SYMBOLS-USED-BY-OTHER-LEVELS*)))
  );1free-symtab


3(DEFUN FIND-TYPE-OF-VAR-ACCESS (access &aux info ty)**
  2"returns the type of a variable access for ACCESS which is a type identifier"*
  (case (op-name (oper access))
    (*record-accessor*
     (setf info (lookup-symtab (find-type-of-var-access (arg1 access))))
     (setf ty (cdr (assoc (arg1 (arg2 access))
			  (get-field-name-list (record-fields info)))))
     (or ty (warn "FIND-TYPE-OF-VAR-ACCESS2:  *Illegal field given in record access")))
    (*pointer-accessor*
     (symtab-domain-type (lookup-symtab (find-type-of-var-access (arg1 access)))))
    (*array-accessor*
     (type-of-array (lookup-symtab (find-type-of-var-access (arg1 access)))))
    (*identifier* (var-type (lookup-symtab (arg1 access))))))


1;;; CHECK-CONTROL-VARIABLE checks that the identifier of the control variable specified
;;; in a FOR statement is declared in the closest block containing the FOR.  That the
;;; control variable is of ordinal type and that the initial and final values of the
;;; FOR are TYPE compatible with the control variable.  Returns NIL if compatible, T otherwise
;;; Of course, we aren't doing any type checking so this just returns NIL.  Note: if you
;;; decide you want to do type checking (why would you??) you probably want to change DEFSUBST
;;; to DEFUN.
3(DEFUN CHECK-CONTROL-VARIABLE (control-var init-value final-value)**
  (ignore control-var init-value final-value)
  nil)


1;;; CHECK-ASSIGNMENT-COMPATIBILITY checks that EXPRESSION is assignment compatible (see ANSI 6.4.6,
;;; p.46 for what they say is a definition) with TYPE-ID.  Also checks that functional and procedural
;;; parameters match.    Returns NIL if compatible, T otherwise.
;;; Again we're not crazy and don't do any real checking.
3(DEFUN CHECK-ASSIGNMENT-COMPATIBILITY (type-id1 type-id2)**
  (ignore type-id1 type-id2)
  nil)


3(DEFUN FIND-BOUNDS-OF-ORDINAL-TYPE (type-id &aux (info (lookup-symtab type-id)))*
  "2returns upper and lower bound of ordinal type TYPE-ID"*
   (declare (values upper-bound lower-bound))
   (cond ((typep info 'symtab-subrange-type)
	  (values (largest info) (smallest info)))
	 ((typep info 'symtab-enumerated-type)
	  (values (highest-enum info) (lowest-enum info)))
	 ((and (typep info 'primitive-type)
	       (eq (required-type info) :boolean))
	  (values ''true ''false))
	 ((and (typep info 'primitive-type)
	       (eq (required-type info) :char))
	  (values biggest-character smallest-character))
	 (t (warn "FIND-BOUNDS-OF-ORDINAL-TYPE2:  *The type ~A is not an ordinal type (or is INTEGER or REAL) in2 *"	
		  (access-form info))))
   );1find-bounds-of-ordinal-type


3(DEFUN DUMP-SYMTAB (&optional (low 0) (up nil))**
  2"dumps the symbol table--LOW and UP and limits of LEVEL of symboled that should be dumped"*
  (declare (special low up))
  (when-type-checking
    (check-type low (integer 0 *))
    (check-type up (or null (integer low *))))
  (let (list)
    ;1; select entries to be dumped*
    (maphash #'(lambda (key value)
		 (declare (special low up))
		 (if (and (not (null (current value)))
			  (>= (level (car (current value))) low)
			  (or (not up) (<= (level (car (current value))) up)))
		     (push (cons key (current value)) list)))
	     *SYMTAB*)
    (sort list #'string< :key #'car)
    (dolist (entry list)
      (dolist (x (rest entry))
	(describe-pascalx x)))
    );1let*
  t);1dumb-symtab