;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.
;;;;
;;;;    This program 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 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../Copyright' for full details.

;;;; CMPENV  Environments of the Compiler.

(in-package "COMPILER")

;;; 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 *compiler-phase* 't1)
  (setq *callbacks* nil)
  (setq *max-temp* 0)
  (setq *temp* 0)
  (setq *next-cmacro* 0)
  (setq *next-cfun* 0)
  (setq *last-label* 0)
  (setq *load-objects* (make-hash-table :size 128 :test #'equal))
  (setq *make-forms* nil)
  (setq *permanent-objects* nil)
  (setq *temporary-objects* nil)
  (setq *local-funs* nil)
  (setq *global-var-objects* nil)
  (setq *global-vars* nil)
  (setq *global-funs* nil)
  (setq *linking-calls* nil)
  (setq *global-entries* nil)
  (setq *undefined-vars* nil)
  (setq *reservations* nil)
  (setq *top-level-forms* nil)
  (setq *compile-time-too* nil)
  (setq *clines-string-list* '())
  (setq *function-declarations* nil)
  (setq *inline-functions* nil)
  (setq *inline-blocks* 0)
  (setq *notinline* nil)
  )

(defun next-lcl () (list 'LCL (incf *lcl*)))

(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil))
  (let ((code (incf *next-cfun*)))
    (format nil prefix code (lisp-to-c-name lisp-name))))

(defun next-temp ()
  (prog1 *temp*
         (incf *temp*)
         (setq *max-temp* (max *temp* *max-temp*))))

(defun next-lex ()
  (prog1 (cons *level* *lex*)
         (incf *lex*)
         (setq *max-lex* (max *lex* *max-lex*))))

(defun next-env () (prog1 *env*
		     (incf *env*)
		     (setq *max-env* (max *env* *max-env*))))

(defun find-global-function (fname)
  (find fname *global-funs* :key #'fun-name :test #'same-fname-p))

(defun function-arg-types (arg-types &aux (types nil))
  (do ((al arg-types (cdr al)))
      ((or (endp al)
           (member (car al) '(&optional &rest &key)))
       (nreverse types))
      (declare (object al))
      (push (type-filter (car al)) types)))

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

(defun function-return-type (return-types)
  (cond ((endp return-types) t)
        ((and (consp (car return-types))
              (eq (caar return-types) 'VALUES))
         (cond ((not (endp (cdr return-types)))
                (warn "The function return types ~s is illegal." return-types)
                t)
               ((or (endp (cdar return-types))
                    (member (cadar return-types) '(&optional &rest &key)))
                t)
               (t (type-filter (cadar return-types)))))
        (t (type-filter (car return-types)))))

(defun add-function-proclamation (fname decl)
  (if (symbolp fname)
      (let* ((arg-types '*)
	     (return-types '*)
	     (l decl))
	(cond ((null l))
	      ((consp l)
	       (setf arg-types (pop l)))
	      (t (warn "The function proclamation ~s ~s is not valid."
		       fname decl)))
	(cond ((null l))
	      ((and (consp l) (null (rest l)))
	       (setf return-types (function-return-type l)))
	      (t (warn "The function proclamation ~s ~s is not valid."
		       fname decl)))
	(if (eq arg-types '*)
	    (rem-sysprop fname 'PROCLAIMED-ARG-TYPES)
	    (put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types))
	(if (eq return-types '*)
	    (rem-sysprop fname 'PROCLAIMED-RETURN-TYPE)
	    (put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)))
      (warn "The function proclamation ~s ~s is not valid." fname decl)))

(defun add-function-declaration (fname arg-types return-types)
  (if (si::valid-function-name-p fname)
      (let ((fun (cmp-env-search-function fname)))
	(if (functionp fun)
	    (warn "Found function declaration for local macro ~A" fname)
	    (push (list fun
			(function-arg-types arg-types)
			(function-return-type return-types))
		  *function-declarations*)))
      (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname)))

(defun get-arg-types (fname)
  (let ((x (assoc fname *function-declarations*)))
    (if x
	(second x)
	(get-sysprop fname 'PROCLAIMED-ARG-TYPES))))

(defun get-return-type (fname)
  (let ((x (assoc fname *function-declarations*)))
    (if x
	(third x)
	(get-sysprop fname 'PROCLAIMED-RETURN-TYPE))))

(defun get-local-arg-types (fun &aux x)
  (if (setq x (assoc fun *function-declarations*))
      (second x)
(defun get-arg-rep-types (fname)
  (get-sysprop fname 'PROCLAIMED-ARG-REP-TYPES))

(defun get-return-rep-type (fname)
  (or (si:get-sysprop fname 'PROCLAIMED-RETURN-REP-TYPE) :object))

; currently we represent unboxed declarations as
; (c-name rep-types return-type)

(defun funboxed-c-name (unboxed)
  (first unboxed))

(defun funboxed-arg-rep-types (unboxed)
  (second unboxed))

(defun funboxed-return-rep-type (unboxed)
  (or (third unboxed) :object))

(defun funboxed-c-exported (unboxed)
  (fourth unboxed))

(defun get-funboxed (fname)
  (get-sysprop fname 'si::c-funboxed))

(defun get-funboxed-arg-rep-types (fname)
  (funboxed-arg-rep-types (get-funboxed fname)))

(defun get-funboxed-return-rep-type (fname)
  (funboxed-return-rep-type (get-funboxed fname)))

(defun get-unboxed (fname)
  (get-sysprop fname 'si::c-unboxed))

(defun get-unboxed-rep-type (name)
  (unboxed-rep-type (get-unboxed name)))

(defun unboxed-c-name (unboxed)
  (first unboxed))

(defun unboxed-rep-type (unboxed)
  (second unboxed))

(defun unboxed-c-exported (unboxed)
  (third unboxed))

      nil))

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

(defun get-proclaimed-narg (fun)
  (multiple-value-bind (x found)
      (get-sysprop fun 'PROCLAIMED-ARG-TYPES)
    (if found
      (let ((minarg (length x)))
	(if (eq (first (last x)) '*)
	  (setf minarg (1- minarg)
		maxarg call-arguments-limit)
	  (setf maxarg minarg))
	(values minarg maxarg))
      (values 0 call-arguments-limit))))

;;; Proclamation and declaration handling.

(defun inline-possible (fname)
  (not (or ; (compiler-push-events)
	(member fname *notinline* :test #'same-fname-p)
	(and (symbolp fname) (get-sysprop fname 'CMP-NOTINLINE)))))

#-:CCL
(defun proclaim (decl)
  (unless (listp decl)
	  (error "The proclamation specification ~s is not a list" decl))
  (case (car decl)
    (SPECIAL
     (dolist (var (cdr decl))
       (if (symbolp var)
           (sys:*make-special var)
           (error "Syntax error in proclamation ~s" 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 (second x)))
               (not (<= 0 (second x) 3)))
           (warn "The OPTIMIZE proclamation ~s is illegal." x)
           (case (car x)
		 (DEBUG)
                 (SAFETY (setq *safety* (second x)))
                 (SPACE (setq *space* (second x)))
                 (SPEED (setq *speed* (second x)))
                 (COMPILATION-SPEED (setq *speed* (- 3 (second x))))
                 (t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
    (TYPE
     (if (consp (cdr decl))
         (proclaim-var (second decl) (cddr decl))
         (error "Syntax error in proclamation ~s" decl)))
    (FTYPE
     (let (ftype)
       (cond ((and (consp (cdr decl))
		   (consp (setf ftype (second decl)))
		   (eq (first ftype) 'FUNCTION))
	      (dolist (v (cddr decl))
		(add-function-proclamation v (rest ftype))))
	     (t (error "Syntax error in proclamation ~a" decl)))))
    (INLINE
     (dolist (fun (cdr decl))
       (if (si::valid-function-name-p fun)
	   (rem-sysprop fun 'CMP-NOTINLINE)
	   (error "Not a valid function name ~s in proclamation ~s" fun decl))))
    (NOTINLINE
     (dolist (fun (cdr decl))
       (if (si::valid-function-name-p fun)
	   (put-sysprop fun 'CMP-NOTINLINE t)
	   (error "Not a valid function name ~s in proclamation ~s" fun decl))))
    ((OBJECT IGNORE DYNAMIC-EXTENT IGNORABLE)
     ;; FIXME! IGNORED!
     (dolist (var (cdr decl))
       (unless (si::valid-function-name-p var)
	 (error "Not a valid function name ~s in ~s proclamation" fun (car decl)))))
    (DECLARATION
     (do-declaration (rest decl) #'error))
    (SI::C-EXPORT-FNAME
     (dolist (x (cdr decl))
       (cond ((symbolp x)
	      (multiple-value-bind (found c-name)
		  (si::mangle-name x t)
		(if found
		    (warn "The function ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." x)
		    (put-sysprop x 'Lfun c-name))))
	     ((consp x)
	      (destructuring-bind (c-name lisp-name) x
		(if (si::mangle-name lisp-name)
		    (warn "The funciton ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." lisp-name)
		    (put-sysprop lisp-name 'Lfun c-name))))
	     (t
	      (error "Syntax error in proclamation ~s" decl)))))
    ((ARRAY ATOM BASE-CHAR BIGNUM BIT BIT-VECTOR CHARACTER COMPILED-FUNCTION
      COMPLEX CONS DOUBLE-FLOAT EXTENDED-CHAR FIXNUM FLOAT HASH-TABLE INTEGER KEYWORD LIST
      LONG-FLOAT NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO RATIONAL
    (SI::C-UNBOXED
     (dolist (x (cddr decl))
       ; put in syntax checking -- fixme
       (put-sysprop x 'si::c-unboxed (second decl))))
    (SI::C-FUNBOXED
     (dolist (x (cddr decl))
       ; put in syntax checking -- fixme
       (put-sysprop x 'si::c-funboxed (second decl))))
      READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR
      SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING
      SYMBOL T VECTOR SIGNED-BYTE UNSIGNED-BYTE FUNCTION)
     (proclaim-var (car decl) (cdr decl)))
    (otherwise
     (unless (member (car decl) si:*alien-declarations*)
       (warn "The declaration specifier ~s is unknown." (car decl)))
     (and (functionp (get-sysprop (car decl) :proclaim))
	  (dolist (v (cdr decl))
		    (funcall (get-sysprop (car decl) :proclaim) v))))
    )
  nil
  )

(defun type-name-p (name)
  (or (get-sysprop name 'SI::DEFTYPE-DEFINITION)
      (find-class name nil)
      (get-sysprop name 'SI::STRUCTURE-TYPE)))

(defun do-declaration (names-list error)
  (declare (si::c-local))
  (dolist (new-declaration names-list)
    (unless (symbolp new-declaration)
      (funcall error "The declaration ~s is not a symbol" new-declaration))
    (when (type-name-p new-declaration)
      (funcall error "Symbol name ~S cannot be both the name of a type and of a declaration"
	       new-declaration))
    (pushnew new-declaration si:*alien-declarations*)))

(defun proclaim-var (type vl)
  (setq type (type-filter type))
  (dolist (var vl)
    (if (symbolp var)
	(let ((type1 (get-sysprop 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))))
	  (unless type1
	    (warn
	     "Inconsistent type declaration was found for the variable ~s."
	     var)
	    (setq type1 T))
	  (put-sysprop var 'CMP-TYPE type1)
	  (when v (setf (var-type v) type1)))
	(warn "The variable name ~s is not a symbol." var))))

(defun c1body (body doc-p &aux
	            (all-declarations nil)
		    (ss nil)		; special vars
		    (is nil)		; ignored vars
		    (ts nil)		; typed vars (var . type)
		    (others nil)	; all other vars
	            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))
      (push form all-declarations)
      (dolist (decl (cdr form))
        (cmpassert (and (proper-list-p decl) (symbolp (first decl)))
		   "Syntax error in declaration ~s" form)
	(let* ((decl-name (first decl))
	       (decl-args (rest decl)))
	  (flet ((declare-variables (type var-list)
		   (cmpassert (proper-list-p var-list #'symbolp)
			      "Syntax error in declaration ~s" decl)
		   (when type
		     (dolist (var var-list)
		       (push (cons var type) ts)))))
	    (case decl-name
	      (SPECIAL
	       (cmpassert (proper-list-p decl-args #'symbolp)
			  "Syntax error in declaration ~s" decl)
	       (setf ss (append decl-args ss)))
	      (IGNORE
	       (cmpassert (proper-list-p decl-args #'symbolp)
			  "Syntax error in declaration ~s" decl)
	       (setf is (append decl-args is)))
	      (TYPE
	       (cmpassert decl-args "Syntax error in declaration ~s" decl)
	       (declare-variables (type-filter (first decl-args))
				  (rest decl-args)))
	      (OBJECT
	       (declare-variables 'OBJECT decl-args))
	      ;; read-only variable treatment. obsolete!
	      (:READ-ONLY)
	      ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL SI::C-UNBOXED SI::C-FUNBOXED
		DYNAMIC-EXTENT IGNORABLE VALUES)
	       (push decl others))
	      (otherwise
	       (if (member decl-name si::*alien-declarations*)
		 (push decl others)
		 (multiple-value-bind (ok type)
		     (valid-type-specifier decl-name)
		   (cmpassert ok "The declaration specifier ~s is unknown." decl-name)
		   (declare-variables type decl-args))))
	      )))))
     (t (return)))
    (pop body)
    )
  (values body ss ts is others doc all-declarations)
  )

(defun c1add-declarations (decls &aux (dl nil))
  (dolist (decl decls dl)
    (case (car decl)
      (OPTIMIZE
       (push decl dl)
       (dolist (x (cdr decl))
	 (when (symbolp x) (setq x (list x 3)))
	 (if (or (not (consp x))
		 (not (consp (cdr x)))
		 (not (numberp (second x)))
		 (not (<= 0 (second x) 3)))
	   (cmpwarn "The OPTIMIZE proclamation ~s is illegal." x)
	   (case (car x)
	     (DEBUG)
	     (SAFETY (setq *safety* (second x)))
	     (SPACE (setq *space* (second x)))
	     ((SPEED COMPILATION-SPEED))
	     (t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x)))))))
      (FTYPE
       (let (ftype)
	 (cond ((and (consp (cdr decl))
		     (consp (setq ftype (second decl)))
		     (eq (first ftype) 'FUNCTION))
		(dolist (v (cddr decl))
		  (add-function-declaration v (second ftype) (cddr ftype))))
	       (t (cmpwarn "Syntax error in declaration ~s" decl)))))
      (INLINE
       (push decl dl)
       (dolist (fun (cdr decl))
	 (if (symbolp fun)
	   (setq *notinline* (remove fun *notinline*))
	   (cmperr "Not a valid function name ~s in declaration ~s" fun decl))))
      (NOTINLINE
       (push decl dl)
       (dolist (fun (cdr decl))
	 (if (symbolp fun)
	   (push fun *notinline*)
	   (cmperr "Not a valid function name ~s in declaration ~s" fun decl))))
      (DECLARATION
       (do-declaration (rest decl) #'cmperr))
      ((SI::C-LOCAL SI::C-GLOBAL SI::C-FUNBOXED SI::C-UNBOXED))
      ((DYNAMIC-EXTENT IGNORABLE)
       ;; FIXME! SOME ARE IGNORED!
       )
      (otherwise
       (unless (member (car decl) si:*alien-declarations*)
	 (cmpwarn "The declaration specifier ~s is unknown." (car decl)))))))

(defun c1decl-body (decls body)
  (if (null decls)
      (c1progn body)
      (let* ((*function-declarations* *function-declarations*)
	     (si:*alien-declarations* si:*alien-declarations*)
	     (*notinline* *notinline*)
	     (*safety* *safety*)
	     (*space* *space*)
 	     (*speed* *speed*)
	     (dl (c1add-declarations decls)))
	(setq body (c1progn body))
	(make-c1form 'DECL-BODY body dl body))))

(put-sysprop 'decl-body 'c2 'c2decl-body)

(defun c2decl-body (decls body)
  (let ((*safety* *safety*)
        (*space* *space*)
	(*speed* *speed*)
        (*notinline* *notinline*))
    (c1add-declarations decls)
    (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)))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; COMPILER ENVIRONMENT
;;;

(defmacro cmp-env-new ()
  '(cons nil nil))

(defun cmp-env-copy (&optional (env *cmp-env*))
  (cons (car env) (cdr env)))

(defmacro cmp-env-variables (&optional (env '*cmp-env*))
  `(car ,env))

(defmacro cmp-env-functions (&optional (env '*cmp-env*))
  `(cdr ,env))

(defun cmp-env-register-var (var &optional (env *cmp-env*) (boundp t))
  (push (list (var-name var)
	      (if (member (var-kind var) '(special global))
		  :special
		  t)
	      boundp
	      var)
	(cmp-env-variables)))

(defun cmp-env-declare-special (name &optional (env *cmp-env*))
  (cmp-env-register-var (c1make-global-variable name :warn nil :kind 'SPECIAL)
			env nil))

(defun cmp-env-register-function (fun &optional (env *cmp-env*))
  (push (list (fun-name fun) 'function fun)
	(cmp-env-functions env)))

(defun cmp-env-register-macro (name function &optional (env *cmp-env*))
  (push (list name 'si::macro function)
	(cmp-env-functions env)))

(defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*))
  (push (list name 'si::symbol-macro #'(lambda (whole env) form))
	(cmp-env-variables env)))

(defun cmp-env-register-block (blk &optional (env *cmp-env*))
  (push (list :block (blk-name blk) blk)
	(cmp-env-variables env)))

(defun cmp-env-register-tag (tag &optional (env *cmp-env*))
  (push (list :tag (list (tag-name tag)) tag)
	(cmp-env-variables env)))

(defun cmp-env-search-function (name &optional (env *cmp-env*))
  (let ((ccb nil)
	(clb nil)
	(unw nil)
	(found nil))
    (dolist (record (cmp-env-functions env))
      (cond ((eq record 'CB)
	     (setf ccb t))
	    ((eq record 'LB)
	     (setf clb t))
	    ((eq record 'UNWIND-PROTECT)
	     (setf unw t))
	    ((atom record)
	     (baboon))
	    ((eq (first record) name)
	     (setf found (first (last record)))
	     (return))))
    (values found ccb clb unw)))

(defun cmp-env-search-variables (type name env)
  (let ((ccb nil)
	(clb nil)
	(unw nil)
	(found nil))
    (dolist (record (cmp-env-variables env))
      (cond ((eq record 'CB)
	     (setf ccb t))
	    ((eq record 'LB)
	     (setf clb t))
	    ((eq record 'UNWIND-PROTECT)
	     (setf unw t))
	    ((atom record)
	     (baboon))
	    ((not (eq (first record) type)))
	    ((eq type :block)
	     (when (eq name (second record))
	       (setf found record)
	       (return)))
	    ((eq type :tag)
	     (when (member name (second record) :test #'eql)
	       (setf found record)
	       (return)))
	    ((eq (second record) 'si::symbol-macro)
	     (when (eq name 'si::symbol-macro)
	       (setf found record))
	     (return))
	    (t
	     (setf found record)
	     (return))))
    (values (first (last found)) ccb clb unw)))

(defun cmp-env-search-block (name &optional (env *cmp-env*))
  (cmp-env-search-variables :block name env))

(defun cmp-env-search-tag (name &optional (env *cmp-env*))
  (cmp-env-search-variables :tag name env))

(defun cmp-env-search-symbol-macro (name &optional (env *cmp-env*))
  (cmp-env-search-variables name 'si::symbol-macro env))

(defun cmp-env-search-var (name &optional (env *cmp-env*))
  (cmp-env-search-variables name t env))

(defun cmp-env-search-macro (name &optional (env *cmp-env*))
  (let ((f (cmp-env-search-function name env)))
    (if (functionp f) f nil)))

(defun cmp-env-mark (mark &optional (env *cmp-env*))
  (cons (cons mark (car env))
	(cons mark (cdr env))))

(defun cmp-env-new-variables (new-env old-env)
  (loop for i in (ldiff (cmp-env-variables *cmp-env*)
			(cmp-env-variables old-env))
	when (and (consp i) (var-p (fourth i)))
	collect (fourth i)))