;;; CMPENV  Environments of the Compiler.
;;;
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa

;; This file is part of GNU Common Lisp, herein referred to as GCL
;;
;; GCL is free software; you can redistribute it and/or modify it under
;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; GCL is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
;; License for more details.
;; 
;; You should have received a copy of the GNU Library General Public License 
;; along with GCL; see the file COPYING.  If not, write to the Free Software
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.


(in-package 'compiler)

(defvar *safe-compile* nil)
(defvar *compiler-check-args* nil)
(defvar *compiler-push-events* nil)
(defvar *speed* 3)
(defvar *space* 0)

;;; Only these flags are set by the user.
;;; If *safe-compile* is ON, some kind of run-time checks are not
;;; included in the compiled code.  The default value is OFF.



(defun init-env ()
  (setq *next-cvar* 0)
  (setq *next-cmacro* 0)
  (setq *next-vv* -1)
  (setq *next-cfun* 0)
  (setq *last-label* 0)
  (setq *objects* nil)
  (setq *constants* nil)
  (setq *local-funs* nil)
  (setq *global-funs* nil)
  (setq *global-entries* nil)
  (setq *undefined-vars* nil)
  (setq *reservations* nil)
  (setq *closures* nil)
  (setq *top-level-forms* nil)
  (setq *non-package-operation* nil)
  (setq *function-declarations* nil)
  (setq *inline-functions* nil)
  (setq *inline-blocks* 0)
  (setq *notinline* nil)
  )

(defvar *next-cvar* 0)
(defvar *next-cmacro* 0)
(defvar *next-vv* -1)
(defvar *next-cfun* 0)

;;; *next-cvar* holds the last cvar number used.
;;; *next-cmacro* holds the last cmacro number used.
;;; *next-vv* holds the last VV index used.
;;; *next-cfun* holds the last cfun used.

(defmacro next-cfun () '(incf *next-cfun*))

(defun add-symbol (symbol)
  (let ((x (assoc symbol *objects*)))
       (cond (x (cadr x))
             (t (push-data-incf symbol)
                (push (list symbol *next-vv*) *objects*)
		*next-vv*))))

;; Write to a string with all the *print-.. levels bound appropriately.
(defun wt-to-string (x &aux
		       (*compiler-output-data* (make-string-output-stream))
		       *fasd-data*)
  (wt-data1 x)
  (get-output-stream-string *compiler-output-data*))

(defun add-object (object &aux x)
  ;;; Used only during Pass 1.
  (cond ((si:contains-sharp-comma object)
         ;;; SI:CONTAINS-SHARP-COMMA returns T iff OBJECT
         ;;; contains a sharp comma OR a structure.
	 ;; there will be an eval and we want the eval to happen
	 (cond ((and
		 (consp object)
		 (eq (car object) 'si::|#,|)
		 (not (si:contains-sharp-comma (cdr object))))
		(setq object (cdr object)))
	       (t (setq object `(si::string-to-object
				 ,(wt-to-string object)))))
	 (push-data-incf nil)
         (push (list *next-vv* object) *sharp-commas*)
         *next-vv*)
        ((setq x (assoc object *objects*))
         (cadr x))
	((typep object 'compiled-function)
	 (push-data-incf nil)
         (push (list *next-vv* `(function 
				 ,(or (si::compiled-function-name
				       object)
				      (cmperr "Can't dump un named compiled funs")
				      )))
				 *sharp-commas*)
         *next-vv*
	 )
        (t 
	   (push-data-incf object)
           (push (list object *next-vv*) *objects*)
           *next-vv*)))

(defun add-constant (symbol &aux x)
  ;;; Used only during Pass 1.
  (cond ((setq x (assoc symbol *constants*))
         (cadr x))
        (t (push-data-incf nil)
           (push (list *next-vv* symbol) *sharp-commas*)
           (push (list symbol *next-vv*) *constants*)
           *next-vv*)))

(defmacro next-cvar () '(incf *next-cvar*))
(defmacro next-cmacro () '(incf *next-cmacro*))

;;; Tail recursion information.
(defvar *do-tail-recursion* t)
(defvar *tail-recursion-info* nil)
;;; Tail recursion optimization never occurs if *do-tail-recursion* is NIL.
;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
;;; If possible, *tail-recursion-info* holds
;;;	( fname  required-arg .... required-arg ),
;;; where each required-arg is a var-object.


(defvar *function-declarations* nil)
;;; *function-declarations* holds :
;;;	(... ( { function-name | fun-object } arg-types return-type ) ...)
;;; Function declarations for global functions are ASSOCed by function names,
;;; whereas those for local functions are ASSOCed by function objects.
;;;
;;; The valid argment type declaration is:
;;;	( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] )
;;; though &optional, &rest, and &key return types are simply ignored.

(defun function-arg-types (arg-types &aux vararg (types nil) result)
  (setq result
	(do ((al arg-types (cdr al))
	     (i 0 (the fixnum (+ 1 i))))
	    ((endp al)
	     (reverse types))
	    (declare (fixnum i))
	    (cond ((or (member (car al) '(&optional &rest &key))
		       (equal (car al) '* ))
		   (setq vararg t)
		   (return (reverse (cons '* types)))))
	    ;; only the first 9 args may have proclaimed type different from T
	    (push       (cond 
			       ((< i 9)
				(let ((tem
				       (type-filter (car al))))
				  (if (eq 'integer tem) t tem)))
			      (t (if (eq (car al) '*) '* t)))
			types)))
  ;;only type t args for var arg so far.
  (cond (vararg (do ((v result (cdr v)))
		    ((null v))
		    (setf (car v) (if (eq (car v) '*) '* t)))))
		    
  result)


;;; The valid return type declaration is:
;;;	(( VALUES {type}* )) or ( {type}* ).

(defun function-return-type (return-types)
  (and (eq (car return-types) 'values)
       (setq return-types (cdr return-types)))
  (cond ((endp return-types) nil)
        ((and (consp (car return-types))
              (eq (caar return-types) 'values))
	 (function-return-type (cdr (car return-types))))
	(t (do ((v return-types (cdr v))
		(result))
	       ((endp v)(or (null v)
			    (warn "The function return type ~s is illegal."
				  return-types))
		(nreverse result))
	     (let ((tem  (if (eq (car v) '*) '* (type-filter (car v)))))
	       (if (eq tem 'integer) (setq tem t))
	       (push  tem result))))))
		
(defun add-function-proclamation (fname decl list &aux (procl t)
					arg-types return-types)
  (cond
    ((and (symbolp fname)
	  (listp decl) (listp (cdr decl)))
     (cond ((or (null decl)(eq (car decl) '*)) (setq arg-types '(*)))
	   (t (setq arg-types (function-arg-types (car decl)))

	      ))
     (setq return-types (function-return-type (cdr decl)))
     (cond ((and (consp return-types)  ; ie not nil
		 (endp (cdr return-types))
		 (not (eq (car return-types) '*)))
	    (setq return-types
		  ;; varargs must return type t currently.
		  (if (member '* (and (consp arg-types) arg-types)) t
		      (car return-types))))
	   (t (setq procl nil)))
     (cond ((and (listp arg-types)
		 (< (length arg-types) call-arguments-limit)))
	   (t (setq procl nil)))
     (do ((fname fname (car list)))
	 (())
	 (or (symbolp fname)
	     (return (add-function-proclamation fname decl nil)))
	 (if (eq arg-types '*)
	     (remprop fname  'proclaimed-arg-types)
	   (si:putprop fname  arg-types  'proclaimed-arg-types))
	 (si:putprop fname return-types  'proclaimed-return-type)
     
	 ;;; A non-local function may have local entry only if it returns
	 ;;; a single value.

	 (if procl  (si:putprop fname t 'proclaimed-function)
	   (remprop fname 'proclaimed-function))
	 (setq list (cdr list))
	 (or (consp list) (return 'done))
	 ))
    (t (warn "The function procl ~s ~s is not valid." fname decl))))

(defun add-function-declaration (fname arg-types return-types)
  (cond ((symbolp fname)
         (push (list (sch-local-fun fname)
                     (function-arg-types arg-types)
                     (function-return-type return-types))
               *function-declarations*))
        (t (warn "The function name ~s is not a symbol." fname))))

(defun get-arg-types (fname &aux x)
  (if (setq x (assoc fname *function-declarations*))
      (cadr x)
      (get fname 'proclaimed-arg-types)))

(defun get-return-type (fname)
  (let* ((x (assoc fname *function-declarations*))
         (type1 (if x (caddr x) (get fname 'proclaimed-return-type)))
	 (type (if (get fname 'predicate) 'boolean
		 (get fname 'return-type))))
        (cond (type1
	       (cond (type
		      (cond ((setq type (type-and type type1)) type)
			    (t
			     (cmpwarn
			      "The return type of ~s was badly declared."
			      fname))))
		     (t type1)))
              (t type))))

(defun get-local-arg-types (fun &aux x)
  (if (setq x (assoc fun *function-declarations*))
      (cadr x)
      nil))

(defun get-local-return-type (fun &aux x)
  (if (setq x (assoc fun *function-declarations*))
      (caddr x)
      nil))

(defvar *sup-used* nil)
(defvar *base-used* nil)

(defun reset-top ()
       (wt "vs_top=sup;")
       (setq *sup-used* t))

(defmacro base-used () '(setq *base-used* t))

;;; Proclamation and declaration handling.

(defvar *alien-declarations* nil)
(defvar *notinline* nil)

(defun inline-possible (fname)
       (not (or *compiler-push-events*
                (member fname *notinline*)
                (get fname 'cmp-notinline))))

(defun proclaim (decl)
  (case (car decl)
    (special
     (dolist** (var (cdr decl))
       (if (symbolp var)
           (si:*make-special var)
           (warn "The variable name ~s is not a symbol." var))))
    (optimize
     (dolist (x (cdr decl))
       (when (symbolp x) (setq x (list x 3)))
       (if (or (not (consp x))
               (not (consp (cdr x)))
               (not (numberp (cadr x)))
               (not (<= 0 (cadr x) 3)))
           (warn "The OPTIMIZE proclamation ~s is illegal." x)
           (case (car x)
                 (safety (setq *compiler-check-args* (>= (cadr x) 1))
                         (setq *safe-compile* (>= (cadr x) 2))
                         (setq *compiler-push-events* (>= (cadr x) 3)))
                 (space (setq *space* (cadr x)))
                 (speed (setq *speed* (cadr x)))
                 (compilation-speed (setq *speed* (- 3 (cadr x))))
                 (t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
    (type
     (if (consp (cdr decl))
         (proclaim-var (cadr decl) (cddr decl))
         (warn "The type declaration ~s is illegal." decl)))
    ((fixnum character short-float long-float)
     (proclaim-var (car decl) (cdr decl)))
    (ftype
      (cond ((and (consp (cdr decl))
		  (consp (cadr decl))
		  (eq (caadr decl) 'function))
	     (add-function-proclamation (caddr decl) (cdr (cadr decl))
					(cddr decl)))
	  (t (cmpwarn "Bad function proclamation ~a" decl))))
   (function
    (cond ((and (consp (cdr decl)))
		(add-function-proclamation (cadr decl) (cddr decl) nil))
	  (t (cmpwarn "Bad function proclamation ~a" decl))))
    (inline
     (dolist** (fun (cdr decl))
               (if (symbolp fun)
                   (remprop fun 'cmp-notinline)
                   (warn "The function name ~s is not a symbol." fun))))
    (notinline
     (dolist** (fun (cdr decl))
               (if (symbolp fun)
                   (si:putprop fun t 'cmp-notinline)
                   (warn "The function name ~s is not a symbol." fun))))
    ((object ignore)
     (dolist** (var (cdr decl))
       (unless (symbolp var)
               (warn "The variable name ~s is not a symbol." var))))
    (declaration
     (dolist** (x (cdr decl))
       (if (symbolp x)
           (unless (member x *alien-declarations*)
                   (push x *alien-declarations*))
           (warn "The declaration specifier ~s is not a symbol." x))))
    ((array atom bignum bit bit-vector character common compiled-function
      complex cons double-float fixnum float hash-table integer keyword list
      long-float nil null number package pathname random-state ratio rational
      readtable sequence short-float simple-array simple-bit-vector
      simple-string simple-vector single-float standard-char stream string
      string-char symbol t vector signed-byte unsigned-byte)
     (proclaim-var (car decl) (cdr decl)))
    (otherwise
     (unless (member (car decl) *alien-declarations*)
             (warn "The declaration specifier ~s is unknown." (car decl)))
   (and (functionp (get (car decl) :proclaim))
        (dolist** (v (cdr decl))
          (funcall (get (car decl) :proclaim) v)))
)
    )
  nil
  )

(defun proclaim-var (type vl)
  (setq type (type-filter type))
  (dolist** (var vl)
    (cond ((symbolp var)
           (let ((type1 (get var 'cmp-type))
                 (v (sch-global var)))
                (setq type1 (if type1 (type-and type1 type) type))
                (when v (setq type1 (type-and type1 (var-type v))))
                (when (null type1) (warn
      "Inconsistent type declaration was found for the variable ~s."
                                    var))
                (si:putprop var type1 'cmp-type)
                (when v (setf (var-type v) type1))))
          (t
           (warn "The variable name ~s is not a symbol." var)))))

(defun c1body (body doc-p &aux (ss nil) (is nil) (ts nil) (others nil)
                    doc form)
  (loop
    (when (endp body) (return))
    (setq form (cmp-macroexpand (car body)))
    (cond
     ((stringp form)
      (when (or (null doc-p) (endp (cdr body)) doc) (return))
      (setq doc form))
     ((and (consp form) (eq (car form) 'declare))
      (dolist** (decl (cdr form))
        (cmpck (or (not (consp decl)) (not (symbolp (car decl))))
               "The declaration ~s is illegal." decl)
        (case (car decl)
          (special
           (dolist** (var (cdr decl))
             (cmpck (not (symbolp var))
                    "The special declaration ~s contains a non-symbol ~s."
                    decl var)
             (push var ss)))
          (ignore
           (dolist** (var (cdr decl))
             (cmpck (not (symbolp var))
                    "The ignore declaration ~s contains a non-symbol ~s."
                    decl var)
             (push var is)))
          (type
           (cmpck (endp (cdr decl))
                  "The type declaration ~s is illegal." decl)
           (let ((type (type-filter (cadr decl))))
                (when type
                      (dolist** (var (cddr decl))
                        (cmpck (not (symbolp var))
                          "The type declaration ~s contains a non-symbol ~s."
                          decl var)
                        (push (cons var type) ts)))))
          (object
           (dolist** (var (cdr decl))
             (cmpck (not (symbolp var))
                    "The object declaration ~s contains a non-symbol ~s."
                    decl var)
             (push (cons var 'object) ts)))
	  (:register
           (dolist** (var (cdr decl))
             (cmpck (not (symbolp var))
                    "The register declaration ~s contains a non-symbol ~s."
                    decl var)
	     (push (cons var  'register) ts)
	     ))
          ((fixnum character double-float short-float array atom bignum bit
            bit-vector common compiled-function complex cons float hash-table
            integer keyword list long-float nil null number package pathname
            random-state ratio rational readtable sequence simple-array
            simple-bit-vector simple-string simple-vector single-float
            standard-char stream string string-char symbol t vector
            signed-byte unsigned-byte :dynamic-extent)
           (let ((type (if (eq (car decl) ':dynamic-extent) (car decl)
			 (type-filter (car decl)))))
                (when type
                      (dolist** (var (cdr decl))
                        (cmpck (not (symbolp var))
                          "The type declaration ~s contains a non-symbol ~s."
                          decl var)
                        (push (cons var type) ts)))))
          (otherwise (push decl others))
          )))
     (t (return)))
    (pop body)
    )
  (values body ss ts is others doc)
  )

(defun c1decl-body (decls body &aux (dl nil))
  (if (null decls)
      (c1progn body)
      (let ((*function-declarations* *function-declarations*)
            (*alien-declarations* *alien-declarations*)
            (*notinline* *notinline*)
            (*space* *space*)
	    (*safe-compile* *safe-compile*))
           (dolist** (decl decls dl)
             (case (car decl)
              (optimize
               (dolist (x (cdr decl))
                 (when (symbolp x) (setq x (list x 3)))
                 (if (or (not (consp x))
                         (not (consp (cdr x)))
                         (not (numberp (cadr x)))
                         (not (<= 0 (cadr x) 3)))
                     (warn "The OPTIMIZE proclamation ~s is illegal." x)
                     (case (car x)
                           (safety
			     (setq *safe-compile*
				   (>= (the fixnum (cadr x)) 2))
			     (push (list 'safety (cadr x)) dl))
                           (space (setq *space* (cadr x))
                                  (push (list 'space (cadr x)) dl))
                           ((speed compilation-speed))
                           (t (warn "The OPTIMIZE quality ~s is unknown."
                                    (car x)))))))
              (ftype
               (if (or (endp (cdr decl))
                       (not (consp (cadr decl)))
                       (not (eq (caadr decl) 'function))
                       (endp (cdadr decl)))
                   (warn "The function declaration ~s is illegal." decl)
                   (dolist** (fname (cddr decl))
                     (add-function-declaration
                      fname (cadadr decl) (cddadr decl)))))
              (function
               (if (or (endp (cdr decl))
                       (endp (cddr decl))
                       (not (symbolp (cadr decl))))
                   (warn "The function declaration ~s is illegal." decl)
                   (add-function-declaration
                    (cadr decl) (caddr decl) (cdddr decl))))
              (inline
               (dolist** (fun (cdr decl))
                 (if (symbolp fun)
                     (progn (push (list 'inline fun) dl)
                            (setq *notinline* (remove fun *notinline*)))
                     (warn "The function name ~s is not a symbol." fun))))
              (notinline
               (dolist** (fun (cdr decl))
                 (if (symbolp fun)
                     (progn (push (list 'notinline fun) dl)
                            (push fun *notinline*))
                     (warn "The function name ~s is not a symbol." fun))))
              (declaration
               (dolist** (x (cdr decl))
                 (if (symbolp x)
                     (unless (member x *alien-declarations*)
                             (push x *alien-declarations*))
                     (warn "The declaration specifier ~s is not a symbol."
                           x))))
              (otherwise
               (unless (member (car decl) *alien-declarations*)
                 (warn "The declaration specifier ~s is unknown."
                       (car decl))))
              ))
           (setq body (c1progn body))
           (list 'decl-body (cadr body) dl body)
           )
      )
  )

(si:putprop 'decl-body 'c2decl-body 'c2)

(defun c2decl-body (decls body)
  (let ((*compiler-check-args* *compiler-check-args*)
        (*safe-compile* *safe-compile*)
        (*compiler-push-events* *compiler-push-events*)
        (*notinline* *notinline*)
        (*space* *space*)
	)
       (dolist** (decl decls)
         (case (car decl)
               (safety
                (let ((level (cadr decl)))
                     (declare (fixnum level))
                     (setq *compiler-check-args* (>= level 1)
                           *safe-compile* (>= level 2)
                           *compiler-push-events* (>= level 3))))
               (space (setq *space* (cadr decl)))
               (notinline (push (cadr decl) *notinline*))
               (inline
                (setq *notinline* (remove (cadr decl) *notinline*)))
               (otherwise (baboon))))
       (c2expr body))
  )

(defun check-vdecl (vnames ts is)
  (dolist** (x ts)
    (unless (member (car x) vnames)
      (cmpwarn "Type declaration was found for not bound variable ~s."
               (car x))))
  (dolist** (x is)
    (unless (member x vnames)
      (cmpwarn "Ignore declaration was found for not bound variable ~s." x)))
  )

(defun proclamation (decl)
  (case (car decl)
    (special
     (dolist** (var (cdr decl) t)
       (if (symbolp var)
           (unless (si:specialp var) (return nil))
           (warn "The variable name ~s is not a symbol." var))))
    (optimize
     (dolist (x (cdr decl) t)
       (when (symbolp x) (setq x (list x 3)))
       (if (or (not (consp x))
               (not (consp (cdr x)))
               (not (numberp (cadr x)))
               (not (<= 0 (cadr x) 3)))
           (warn "The OPTIMIZE proclamation ~s is illegal." x)
           (case (car x)
                 (safety
                  (unless (= (cadr x)
                             (cond ((null *compiler-check-args*) 0)
                                   ((null *safe-compile*) 1)
                                   ((null *compiler-push-events*) 2)
                                   (t 3)))
                          (return nil)))
                 (space (unless (= (cadr x) *space*) (return nil)))
                 (speed (unless (= (cadr x) *speed*) (return nil)))
                 (compilation-speed
                  (unless (= (- 3 (cadr x)) *speed*) (return nil)))
                 (t (warn "The OPTIMIZE quality ~s is unknown."
                          (car x)))))))
    (type
     (if (consp (cdr decl))
         (let ((type (type-filter (cadr decl)))
               x)
              (dolist** (var (cddr decl) t)
                (if (symbolp var)
                    (unless (and (setq x (get var 'cmp-type))
                                 (equal x type))
                            (return nil))
                    (warn "The variable name ~s is not a symbol." var))))
         (warn "The type declaration ~s is illegal." decl)))
    ((fixnum character short-float long-float)
     (let ((type (type-filter (car decl)))
           x)
          (dolist** (var (cdr decl) t)
            (if (symbolp var)
                (unless (and (setq x (get var 'cmp-type)) (equal x type))
                        (return nil))
                (warn "The variable name ~s is not a symbol." var)))))
    (ftype
     (if (or (endp (cdr decl))
             (not (consp (cadr decl)))
             (not (eq (caadr decl) 'function))
             (endp (cdadr decl)))
         (warn "The function declaration ~s is illegal." decl)
         (dolist** (fname (cddr decl) t)
           (unless (and (get fname 'proclaimed-function)
                        (equal (function-arg-types (cadadr decl))
                               (get fname 'proclaimed-arg-types))
                        (equal (function-return-type (cddadr decl))
                               (get fname 'proclaimed-return-type)))
                   (return nil)))))
    (function
     (if (or (endp (cdr decl)) (endp (cddr decl)))
         (warn "The function declaration ~s is illegal." decl)
         (and (get (cadr decl) 'proclaimed-function)
              (equal (function-arg-types (caddr decl))
                     (get (cadr decl) 'proclaimed-arg-types))
              (equal (function-return-type (cdddr decl))
                     (get (cadr decl) 'proclaimed-return-type)))))
    (inline (dolist** (fun (cdr decl) t)
              (if (symbolp fun)
                  (when (get fun 'cmp-notinline) (return nil))
                  (warn "The function name ~s is not a symbol." fun))))
    (notinline (dolist** (fun (cdr decl) t)
                 (if (symbolp fun)
                     (unless (get fun 'cmp-notinline) (return nil))
                     (warn "The function name ~s is not a symbol." fun))))
    ((object ignore)
     (dolist** (var (cdr decl) t)
               (unless (symbolp var)
                       (warn "The variable name ~s is not a symbol." var))))
    (declaration (dolist** (x (cdr decl) t)
                   (if (symbolp x)
                       (unless (member x *alien-declarations*) (return nil))
                       (warn "The declaration specifier ~s is not a symbol."
                             x))))
    ((array atom bignum bit bit-vector character common compiled-function
      complex cons double-float fixnum float hash-table integer keyword list
      long-float nil null number package pathname random-state ratio rational
      readtable sequence short-float simple-array simple-bit-vector
      simple-string simple-vector single-float standard-char stream string
      string-char symbol t vector signed-byte unsigned-byte)
     (let ((type (type-filter (car decl))))
          (dolist** (var (cdr decl) t)
            (if (symbolp var)
                (unless (equal (get var 'cmp-type) type) (return nil))
                (warn "The variable name ~s is not a symbol." var)))))
    (otherwise
     (unless (member (car decl) *alien-declarations*)
             (warn "The declaration specifier ~s is unknown." (car decl))))
    )
  )