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


3(DEFCONSTANT PRE-DEFINED-FUNCTIONS-CHANGES* '((CLOSE . *CLOSE*)
						  (GET   . *GET*)
						  (READ  . *READ*)
						  (TIME  . *TIME*))
  2"an alist to check if globally defined function names should be changed"*)


3(DEFUN HIGHEST-ENUM (symtab-enumerated-type-instance)*
   "2returns highest value if this enumeration type"*
;   (declare (function highest-enum (symtab-enumerated-type) counter)
;	    (values index))
   (when-type-checking
     (check-type symtab-enumerated-type-instance symtab-enumerated-type))
   (first (last (poss-values symtab-enumerated-type-instance)))
   );1highest-enum


3(DEFUN LOWEST-ENUM (symtab-enumerated-type-instance)**
   "2returns lowest value if this enumeration type"*
;   (declare (function lowest-enum (symtab-enumerated-type) counter)
;	    (values index))
   (when-type-checking
     (check-type symtab-enumerated-type-instance symtab-enumerated-type))
   (first (poss-values symtab-enumerated-type-instance))
   );1lowest-enum


3(DEFUN GET-OPERATOR (alist)**
  2"finds the appropriate operator out of ALIST"*
;   (declare (function get-operator (list) (or null operator))
;	    (values operator))
   (when-type-checking
     (check-type alist list))
   (let* ((ty (token-type (peek-at-token)))
	 (op  (rest (assoc ty alist))))
     (unless (null op)
       (make-operator-from-token op (lexi)))
    );1let*
  );1get-operator*

(DEFUN APPEND-COMMENT-TO-OPERATOR (OP CMMT)
  (LET ((OLD-COMMENT (OP-COMMENT OP)))
    (COND ((NULL CMMT))			  ; don't need to add comment, just return OP
	  ((NULL OLD-COMMENT)		  ; there is no old comment, just use new one
	   (SETF (OP-COMMENT OP) CMMT))
	  (T (SETF (OP-COMMENT OP)
		   (LIST (STRING-APPEND (CAR (OP-COMMENT OP)) #\SPACE (CAR CMMT))
			 (IF (OR (EQ (CADR CMMT) 'MAJOR)
				 (EQ (CADR (OP-COMMENT OP)) 'MAJOR))
			     'MAJOR 'MINOR)))))
    OP))#|
3(DEFUN APPEND-COMMENT-TO-OPERATOR (operator-instance comment)*
   "2returns OPERATOR-INSTANCE with COMMT in its comment slot"*
;   (declare (function append-comment-to-operator (operator cons) operator)
;	    (values modified-operator-instance))
   (when-type-checking
     (check-type operator-instance operator)
     (check-type comment list))
   (let ((new-comment (first comment))
	 (new-major-minor (second comment))
	 (old-comment (op-comment operator-instance))
	 (old-major-minor (op-major-or-minor operator-instance)))
     (when-type-checking
       (check-type new-comment (or null string))
       (check-type new-major-minor (member nil major minor)))
     (cond ((null comment))		           1; don't need to add comment, just return OPERATOR-INSTANCE*
	   ((null old-comment)		           1; there is no old comment, just use new one*
	    (setf (op-comment operator-instance)        new-comment)
	    (setf (op-major-or-minor operator-instance) new-major-minor))
	   (t (setf (op-comment operator-instance) ;1 merge new comment with old*
		    (concatenate :string old-comment " " new-comment))
	      (setf (op-major-or-minor operator-instance)
		    (if (or (eq old-major-minor 'MAJOR)1 *;1 a major comment dominates*
			    (eq new-major-minor 'MAJOR))
			'MAJOR
			'MINOR)))
	   );1cond*
     );1let*
   operator-instance
  );1append-comment-to-op*
|3#

1;;; APPEND-COMMENT-TO-LAST-OPERATOR takes a list which is a piece of PREFIX** 1and finds the last operator*
;1;; (i.e. the last operator in the last list) and* 1appends comment to it.  the piece of PREFIX is returned
3(DEFUN APPEND-COMMENT-TO-LAST-OPERATOR (prefix comment)**
;   (declare (function append-comment-to-last-operator ((or operator cons) cons) (or operator cons))
;	    (values modified-prefix))
   (when-type-checking
     (check-type prefix (or operator list))
     (check-type comment list))
   (cond ((typep prefix 'operator)
	  (append-comment-to-operator prefix comment))
	 1;; see if this is one of the primitive operators, i.e. a number or identifier*
	 1;; then put the comment on the car of the prefix*
	((and (typep prefix :cons)
	      (not (member (typep (car (last prefix))) '(operator :cons)))
	      (not (null (car (last prefix)))))
	 (append-comment-to-operator (car prefix) comment))
	((typep prefix :cons) (append-comment-to-last-operator (car (last prefix)) comment)))
  prefix
  );1append-comment-to-last-operator


3(DEFUN CHECK-FUNCTION-NAME (pid-instance &aux new-pid-name)**
   2"prompts user for a new symbol name if the old one is already defined in the LISP package"*
;   (declare (function check-function-name (print-identifier) print-identifier))
   (when-type-checking
     (check-type pid-instance print-identifier))
   (when (and (eq (symbol-package (pid-name pid-instance)) (find-package 'lisp))
	      (fboundp (pid-name pid-instance)))
     ;1; then this symbol is already defined, so figure what has to be done about it*
     (if (= *CURRENT-LEVEL* -1)
	 ;1; then we are entering pre-defined symbols, so use pre-defined fix-up*
	 (setf (pid-name pid-instance)
	       (or (rest (assoc (pid-name pid-instance) PRE-DEFINED-FUNCTIONS-CHANGES))
		   (pid-name pid-instance)))
	 
	 ;1; else we are entering symbols from the program being translated, so ask use what to do*
	 (cond (*DEBUG-CODE-GEN-P*
		(format *LOG-STREAM*
			"~%The function ~A is already defined in the package LISP~%" pid-instance)
		pid-instance)
	       
	       (*BATCH-MODE-P*
		(setf (pid-name pid-instance) (gensym (pid-name pid-instance)))
		(setf pid-instance (check-function-name pid-instance)))
	       
	       (t (loop
		    (if (yes-or-no-p "~%The function ~A is already defined in the package LISP.~
                               2   *~%Do you want to redefine it to be something else?" pid-instance)
			;1; then the user wants to input an alternate name*
			(progn
			  (format *QUERY-IO* "~%Input the new name and press RETURN: ")
			  (setf new-pid-name (read-line *QUERY-IO*))	   ;1 get new name*
			  (princ new-pid-name *QUERY-IO*)                  ;1 echo it*
			  (setf new-pid-name (string-upcase (string-trim '(#\SPACE) new-pid-name)))
			  (when (plusp (length new-pid-name))
			    ;1; then new input looks ok so far, but double check it*
			    (setf pid-instance (check-function-name (make-print-identifier
								      :name    (intern new-pid-name)
								      :package (pid-package pid-instance))))
			    (return)	   ;1 we found what we want, so exit the query loop*
			    );1when*
			  );1lprogn*
			
			;1;else user wants to leave well enough alone, so exit query loop*
			(return)
			);1if*
		    ;1; if we reach here, then the new input was not satisfactory, so loop back and try again*
		    );1loop*
		  )
	       );1cond*
	 );1if*
     );1when*
   pid-instance				   ;1 whatever else happens, return the instance*
  );1check-function-name


3(DEFUN GET-FIELD-NAME-LIST (symtab-filed-list-instance)**
  2"return a list of field names"*
;   (declare (function get-field-name-list (symtab-field-list) cons)
;	    (values field-name-list))
   (when-type-checking
     (check-type symtab-filed-list-instance symtab-field-list))
   (append (fixed-fields symtab-filed-list-instance)
	   (and (car (symtab-tag-field symtab-filed-list-instance))
		(list (symtab-tag-field symtab-filed-list-instance)))
	   (when (not (null (variant-fields symtab-filed-list-instance)))
	     (mapcan #'(lambda (x)
			 (get-field-name-list (cdr x)))
		     (variant-fields symtab-filed-list-instance))))
  );1get-field-name-list


3(DEFUN GET-INIT-FORM (info &aux comp-info)**
  2"returns the init form for info"*
;   (declare (function get-init-form ((or symbol symtab-file-type)) cons)
;	    (values info-list))
   (when-type-checking
     (check-type info symbol))
   (cond ((not (typep (lookup-symtab info) 'symtab-file-type))
	  (list (init-function (lookup-symtab info))))
	 (t (setf comp-info (symtab-component-type
				(lookup-symtab info)))
	    (list (init-function (lookup-symtab info))
		  :buffer-variable
;		  (make-print-identifier :name    'buffer-variable
;					 :package 'pascalx)
		  (get-init-form comp-info)
		  :num-of-bits		  
;		  (make-print-identifier :name    'num-of-bits
;					 :package 'pascalx)
		  (num-of-bits (lookup-symtab info))
		  :text-p		  
;		  (make-print-identifier :name    'text?
;					 :package 'pascalx)
		  (or (and (typep (lookup-symtab comp-info)
				  'primitive-type)
			   (eq (required-type (lookup-symtab
						  comp-info)) :char))
		      (and (typep (lookup-symtab comp-info)
				  'symtab-subrange-type)
			   (eq (host-type (lookup-symtab
					      comp-info))
			       :char))))))
  );1get-init-form


3(DEFUN GET-BIT-SIZE-OF-SUBRANGE (info)**
  2"returns how many bits are needed to represent this subrange"*
;   (declare (function get-bit-size-of-subrange (integer) counter)
;	    (values bit-count))
;1  ++ pso*
;   (when-type-checking
;     (check-type info integer))
   (max (integer-length (global:abs (largest  info)))
	(integer-length (global:abs (smallest info))))
   );3get-bit-size-of-subrange 


(DEFUN ABBREV-STRING (str)*
   "2If STR is longer than 20, the first 20 characters are returned with \"...\" on the end.  Otherwise, STR is returned."*
;   (declare (function abbrev-string ((or null string)) string)
;	    (values length-limited-string))
   (when-type-checking
      (check-type str (or null string)))
   (if (or (null str)
	   (<= (length str) 20))
       str
       (concatenate 'string (subseq str 0 20) "..."))
   );1abbrev-string


3(DEFUN ADD-COMMENT-TO-LISP-STRUCT (lisp-struct-instance comment major-or-minor)
2   "adds a comment to the comment field of lisp-struct"***
;   (declare (function add-comment-to-lisp-struct (lisp-struct (or null string) (member 'major 'minor))
;		      lisp-struct)
;	    (values lisp-struct-instance))
   (when-type-checking
     (check-type comment (or null string))
     ;1; ++ added (or null ...*
     (check-type major-or-minor (OR null (member major minor))))
   (when (not (null comment))
     ;1; then there is a new comment to record*
     (if (null (lisp-comment lisp-struct-instance))
	 ;1; then there is no existing comment, so just add it*
	 (progn (setf (lisp-comment        lisp-struct-instance) comment)
		(setf (lisp-major-or-minor lisp-struct-instance) major-or-minor))
	 ;1; else there is an existing comment, so append this one to it*
	 (progn	(setf (lisp-comment lisp-struct-instance)
		      (concatenate 'string comment " " (lisp-comment lisp-struct-instance)))
		(setf (lisp-major-or-minor lisp-struct-instance)
		      (if (or (eq (lisp-major-or-minor lisp-struct-instance) 'major)
			      (eq major-or-minor 'major))
			  ;1; then major dominates*
			  'major
			  ;1; else it is just minor*
			  'minor))
		);1progn*
	 );1if*
     );1when*
   lisp-struct-instance
   );1add-comment-to-list-struct*



;1;;; TOKEN STRUCTURE AUXILIARY FUNCTIONS

3(DEFUN TOKEN-TYPE (token-instance)**
;   (declare (function token-type (token) symbol)
;	    (values symbol-or-type))
   (when-type-checking
     (check-type token-instance token))
   (etypecase  (token-value token-instance)
     (:symbol  (token-value token-instance))
     (:cons    'identifier)
     (:integer 'int-const)
     (:float   'real-const)
     (:string  'string)
     );1etypecase*
   );1token-type


3(DEFUN GET-RAW-TOKEN (token-instance)**
  "2returns original token substring from *LINE-IMAGE*"*
;  (declare (function get-raw-token (token) string)
;	   (values token-string))
  (when-type-checking
    (check-type token-instance token))
  (subseq *LINE-IMAGE* (token-start token-instance) (token-end token-instance))
  );1get-raw-token


3(DEFUN GET-ID-NAME (token-instance)**
  "2assumes TOKEN-INSTANCE is an identifier and returns its print-name interned as a symbol"*
;  (declare (function get-id-name (token) symbol)
;	   (values identifier-symbol))
  (when-type-checking
    (check-type token-instance token))
  (intern (first (token-value token-instance)))
  );1get-id-name


3(DEFUN GET-LABEL (token-instance)**
  "2assumes TOKEN-INSTANCE is a number and returns it interned as a Label symbol"*
;  (declare (function get-label (token) symbol)
;	   (values label-symbol))
  (when-type-checking
    (check-type token-instance token))
  (make-label-into-symbol (token-value token-instance))
  );1get-label


3(DEFUN GET-CONSTANT (token-instance)**
  "2assumes TOKEN-INSTANCE is a number and returns it"*
;  (declare (function get-constant (token) number)
;	   (values number))
  (when-type-checking
    (check-type token-instance token))
  (token-value token-instance)
  );1get-constant


3(DEFUN GET-STRING (token-instance)**
  "2assumes TOKEN-INSTANCE is a number and returns it"*
;  (declare (function get-string (token) string)
;	   (values string))
  (when-type-checking
    (check-type token-instance token))
  (token-value token-instance)
  );1get-string*




;1;;; MISCELLANEOUS DESCRIBE & PRINT FUNCTIONS

3(DEFUN ERROR-HANDLER (function-name format-string &rest format-args)**
  2"general warning function to *ERROR-OUTPUT* with function name prefixed to message"*
;   (declare (function error-handler (symbol string list)))
   (fresh-line *ERROR-OUTPUT*)
   (apply #'global:error (concatenate 'string (string function-name) ":  " format-string) format-args))
;   (apply #'warn (concatenate 'string (string function-name) ":  " format-string) format-args))


3(DEFUN PARSER-ERROR (string function-symbol &optional (place nil))
2   **"2function version of PARSER-ERROR-HANDLER"*
;   (declare (function parser-error (string symbol (or null counter token)) nil)
;	    (values ignore))
   (let ((start  (etypecase place
		    (number  place)
		    (null    nil)
		    (token   (1- (token-start place)))))
	 (line-no (when (typep place 'token) (token-line-no place))))
     (error-handler function-symbol
		    (format nil "~@[~A~%~]
                                 ~@[         ~V,,,' <~>~%~]~
                                 ~A~@[ on line number ~A~]"
				(OR (null *LOG-STREAM*)
				    (EQ *LOG-STREAM*
					'si:null-stream))
				start string line-no))
     );1let*
   );1parser-error


3(DEFUN PRINT-INFO (name line-no)**
;   (declare (function print-info (symbol counter) nil)
;	    (values ignore))
   (when-type-checking
     (check-type name symbol)
     (check-type line-no counter))
   (let ((info (lookup-symtab name)))
	 (check-type info generic-symbol)
	 (if (not (OR (null *LOG-STREAM*) (eq *LOG-STREAM* 'si:null-stream)))
	     (format *LOG-STREAM* "~%~VTGenerating code for ~9A ~15A [level: ~D, line number: ~D]"
		     (* 5 (level info)) (type-of info) (pascal-id info) (level info)
		     line-no))
	 );1let*
   );1print-info


3(DEFUN PRINT-COMMENT (lisp-struct-instance stream)**
;   (declare (function print-comment (lisp-struct stream) nil)
;	    (values ignore))
   (when-type-checking
     (check-type lisp-struct-instance lisp-struct)
     (check-type stream stream))
   (when (and (not (null (lisp-comment lisp-struct-instance)))
	      (not (equal (lisp-comment lisp-struct-instance) "")))
     (if (eq (lisp-major-or-minor lisp-struct-instance) 'major)
	 ;1; then this is a major comment on a line by itself*
	 (format stream "~& ;; ~A~&" (lisp-comment lisp-struct-instance))
	 ;1; else this is an embedded or end of line comment*
	 (format stream "3 *#|~A|#3 *" (car (lisp-comment
				       lisp-struct-instance))))
    );1when*
   );1print-comment


3(DEFUN PPRINT-EXPRESSION (expression stream)**
   "2internal prettyprint routine for GRING-TO-LISP-STREAM"*
;   (declare (function pprint-expression (t stream) nil)
;	    (values ignore))
   (when-type-checking
     (check-type stream stream))
   (let ((*PRINT-LEVEL*  nil)
	 (*PRINT-LENGTH* nil)
	 (*PRINT-PRETTY* nil)
	 (*PRINT-ESCAPE* nil)
	 (*PACKAGE* (find-package *OUTPUT-PACKAGE*)))
     (typecase expression
       (CONS				   ;1 primitive Lisp form, print it as a list*
	(case (first expression)
	      (QUOTE     (write-char #\' stream)                           ;1 write ' prefix *
			 (pprint-expression (second expression) stream))   ;1    followed by rest of expression*
	      (FUNCTION  (write-string "#'" stream)	                   ;1 write #' prefix*
			 (pprint-expression (second expression) stream))   ;1    followed by rest of expression*
	      (otherwise (write-char #\( stream)                           ;1 write ( prefix*
			 (pprint-expression (first expression) stream)     ;1    followed by first subexpression*
			 (dolist (sub-exp (rest expression))	           ;1    followed by remaining subexpressions*
			   (write-char #\Space stream)
			   (pprint-expression sub-exp stream))
			 (write-char #\) stream))                          ;1    followed by ) suffix*
	      );1case*
	);1list*
       
       (PRINT-IDENTIFIER		   ;1 a program symbol, print it with package, if need be *
	(when (eq (pid-package expression) 'pascalx)
	  (princ "PASCALX:" stream))
	(prin1 (pid-name expression) stream)
	);1print-identifier*
       
       (LISP-STRUCT			   ;1 a Lisp form with comment attached*
	(when (eq (lisp-major-or-minor expression) 'major) ;1 print any major comment first on a line by itself*
	  (print-comment expression stream))
	(unless (eq (lisp-form expression) '*comment*)	   ;1 print the form unless it is only a comment*
	  (pprint-expression (lisp-form expression) stream))
	(when (eq (lisp-major-or-minor expression) 'minor) ;1 print any minor comment on the same line*
	  (print-comment expression stream))
	);1lisp-struct*
       
       (otherwise (princ expression stream))	   ;1 just prettyprint anything else*
       );1typecase*
     );1let*
   );1pprint-expression


3(DEFUN GRIND-TO-LISP-STREAM (expression)**
   "2prettyprint EXP to *LISP-STREAM*"*
;   (declare (function grind-to-lisp-stream (t) nil)
;	    (values ignore))
   (let ((*PRINT-LEVEL*  nil)
	 (*PRINT-LENGTH* nil)
	 (*PRINT-PRETTY* t)
	 (*PRINT-ESCAPE* t) ;1; ++ changed to t for packages *7/03/86 12:49:43
	 (*PACKAGE* (find-package *OUTPUT-PACKAGE*)))
     (terpri *LISP-STREAM*)
     (IF *grind-the-def*
	 (grind-top-level expression nil *lisp-stream*)
	 ;1else*
	 (PRIN1 expression *lisp-stream*))
     (terpri *LISP-STREAM*)
     );1let*
   );1grind-to-lisp-stream


3(DEFUN DESCRIBE-PASCALX (object)**
  "2specialized version of DESCRIBE for Pascal Translator"*
;   (declare (function describe-pascalx (t) nil))
  (typecase object
    (lisp-struct               (describe-lisp-struct object))
    (operator                  (describe-operator object))
    (print-identifier          (describe-print-identifier object))
    (generic-symbol
      (typecase object
	(label                     (describe-label object))
	(const                     (describe-const object))
	(var                       (describe-var object))
	(program                   (describe-program object))
	(type
	 (typecase object
	   (primitive-type             (describe-primitive-type object))
	   (symtab-subrange-type       (describe-symtab-subrange-type object))
	   (symtab-pointer-type        (describe-symtab-pointer-type object))
	   (primitive-type             (describe-primitive-type object))
	   (symtab-structured-type
	    (typecase object 
	      (symtab-enumerated-type    (describe-symtab-enumerated-type object))
	      (symtab-array-type         (describe-symtab-array-type object))
	      (symtab-record-type        (describe-symtab-record-type object))
	      (symtab-file-type          (describe-symtab-file-type object))
	      (symtab-set-type           (describe-symtab-set-type object))
	      (otherwise                 (format t "~%WARNING: Unknown SYMTAB-STRUCTURED-TYPE subtype")
					 (describe-structured-type object))
	      );1typecase*
	    );1symtab-structured-type*
	   (otherwise                  (format t "~%WARNING: Unknown TYPE subtype")
				       (describe-type object))
	   );1typecase*
	 );1type*
	(procedure
	 (typecase object
	   (function                   (describe-function object))
	   (otherwise                  (describe-procedure object))
	   );1typecase*
	 );1procedure*
	(otherwise                 (format t "~%WARNING: Unknown GENERIC-SYMBOL subtype")
			           (describe-generic-symbol object))
	);1typecase*
      );1generic-symbol*
    (otherwise                 (describe object))
    );1typecase*
  );1describe-pascalx*




;1;;; MISCELLANEOUS MAKE FUNCTIONS

3(DEFUN MAKE-LEVEL-TAG (level)**
   "2returns LEVEL number interned as a symbol"*
;   (declare (function make-level-tag (pascal-level-no) symbol)
;	    (values new-symbol))
   (when-type-checking
     (check-type level pascal-level-no))
   (intern (format nil "*level-~d*" level))
   );1make-level-tag

3(DEFUN MAKE-LABEL-INTO-THROW-VALUE (label)**
   "2returns LABEL number interned as a THROW symbol"*
;   (declare (function make-label-into-throw (pascal-lable-no) symbol)
;	    (values new-symbol))
   (when-type-checking
     (check-type label (OR symbol print-identifier pascal-label-no)))
   ;1; ++ hack*
   (IF (TYPEP label '(OR print-identifier symbol))
       label
       (INTERN (format nil "*~s*" label)))
   );1make-label-into-throw-value


3(DEFUN MAKE-LISP-STRUCT-FROM-OP (lisp-form operator-instance)**
  "2returns a LISP-STRUCT describing OPERATOR-INSTANACE"*
;  (declare (function make-lisp-struct-from-op (t operator) lisp-struct)
;	   (values list-struct))
  (when-type-checking
    (check-type operator-instance operator))
  (make-lisp-struct lisp-form (op-comment operator-instance) (op-major-or-minor operator-instance))
  );1make-lisp-struct-from-op


3(DEFUN MAKE-IDENTIFIER (string)**
  "2uppercases STRING as returns it as a one element list"*
;   (declare (function make-identifier (string) cons)
;	    (values list-of-string))
   (when-type-checking
     (check-type string string))
   (list (nstring-upcase string))
  );1make-identifier


3(DEFUN MAKE-LABEL-INTO-SYMBOL (label)**
   "2returns LABEL number interned as a \"L-nnnn\" symbol"*
;   (declare (function make-label-into-symbol (pascal-label-no) symbol)
;	    (values label-as-symbol))
   (when-type-checking
     (check-type label pascal-label-no))
   (intern (format nil "L-~D" label))
   );1make-label-into-symbol


3(DEFUN MAKE-OPERATOR-FROM-TOKEN (op-name token-instance)**
   "2returns an instance of OPERATOR built from OP-NAME and the TOKEN-INSTANCE fields"*
;   (declare (function make-operator-from-token (symbol token) operator)
;	    (values operator-instance))
   (when-type-checking
     (check-type token-instance token)
     (check-type op-name symbol string))
   (make-operator op-name (token-comment token-instance) (token-start token-instance)
		  (token-line-no token-instance))
   );1make-operator-from-token*



;1;;; MISCELLANEOUS PREDICATE FUNCTIONS

3(DEFUN PRE-DEFINED (generic-symbol-instance**)
2   *"2returns true if GENERIC-SYMBOL-INSTANCE represents a pre-defined Pascal symbol"*
;   (declare (function pre-defined (generic-symbol) t))
   (when-type-checking
     (check-type generic-symbol-instance generic-symbol))
   (= (level generic-symbol-instance) -1)
  );1pre-defined


3(DEFUN ENUMERATED (const-instance)**
   "2returns true of CONST-INSTNACE represents an enumerated constant"*
;   (declare (function enumerated (const) t))
   (when-type-checking
     (check-type const-instance const))
   (not (null (part-of-type const-instance)))
   );1enumerated


3(DEFUN PRINT-LEVEL-P (stream level)**
  "2If nesting is too deep for printing, outputs #\# to STREAM and returns false.  Otherwise, returns true."*
;   (declare (function print-level-p (stream pascal-level-no) t))
   (not (when (and (not (null *PRINT-LEVEL*))
		   (>= level *PRINT-LEVEL*))
	  ;1; then we are too deeply nested to print, so just print # returning #\# as true*
	  (princ #\# stream)))
  );1print-level-p*

(DEFUN concat (&rest concat-args)
  (APPLY #'CONCATENATE concat-args))

(DEFUN filter-special-formals (specials formals)
2   *"2Returns 2 values: specials formals and other formals*"
  (LET ((r1) (r2))
    (MAPC #'(lambda (special)
	      (IF (MEM
		      #'(lambda (special formal)
			  (EQ special (lisp-form formal)))
		      special formals)
		  (PUSH special r1)
		  (PUSH special r2)))
	  specials)
    (VALUES r1 r2)))