;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

;;;;
;;;;  Copyright (c) 2010, Juan Jose Garcia-Ripoll
;;;;
;;;;    See file 'LICENSE' for the copyright details.

;;;;
;;;; CMPENV-DECLARE -- Declarations for the compiler
;;;;
;;;; Extract, process and incorporate declarations into the compiler
;;;; environment. Unlike proclamations, these are local to the current
;;;; compiled file and do not propagate beyond it.
;;;;

(in-package "COMPILER")

(defun valid-form-p (x &optional test)
  (and (si:proper-list-p x)
       (or (null test)
           (every test x))))

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

(defun validate-alien-declaration (names-list error)
  (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))))

(defun alien-declaration-p (name &optional (env *cmp-env*))
  (and (symbolp name)
       (member name (cmp-env-search-declaration 'alien env si:*alien-declarations*)
               :test 'eq)))

(defun policy-declaration-p (name)
  (and (gethash name *optimization-quality-switches*) t))

(defun parse-ignore-declaration (decl-args expected-ref-number tail)
  (declare (si::c-local))
  (loop for name in decl-args
        do (if (symbolp name)
               (push (cons name expected-ref-number) tail)
               (cmpassert (and (consp name)
                               (= (length name) 2)
                               (eq (first name) 'function))
                          "Invalid argument to IGNORE/IGNORABLE declaration:~&~A"
                          name)))
  tail)

(defun collect-declared (type var-list tail)
  (declare (si::c-local))
  (cmpassert (valid-form-p var-list #'symbolp)
             "Syntax error in declaration ~s" `(TYPE ,type ,var-list))
  (loop for var-name in var-list
     do (push (cons var-name type) tail))
  tail)

(defun c1body (body doc-p)
  "Split a function body into a list of forms, a set of declarations,
and a possible documentation string (only accepted when DOC-P is true)."
  (multiple-value-bind (all-declarations body doc specials)
      (si:process-declarations body doc-p)
    (loop with others = '()
       with types = '()
       with ignored = '()
       for decl in all-declarations
       for decl-name = (first decl)
       for decl-args = (rest decl)
       do (cmpassert (and (valid-form-p decl-args)
                          (or (symbolp decl-name)
                              (and (consp decl-name)
                                   (valid-type-specifier decl-name))))
                     "Syntax error in declaration ~s" decl)
       do (case decl-name
            (cl:SPECIAL)
            (cl:IGNORE
             (cmpassert (valid-form-p decl-args)
                        "Syntax error in declaration ~s" decl)
             (setf ignored (parse-ignore-declaration decl-args -1 ignored)))
            (cl:IGNORABLE
             (cmpassert (valid-form-p decl-args)
                        "Syntax error in declaration ~s" decl)
             (setf ignored (parse-ignore-declaration decl-args 0 ignored)))
            (cl:TYPE
             (cmpassert (and (consp decl-args)
                             (valid-form-p (rest decl-args) #'symbolp))
                        "Syntax error in declaration ~s" decl)
             (setf types (collect-declared (first decl-args)
                                           (rest decl-args)
                                           types)))
            (OBJECT
             (cmpassert (valid-form-p decl-args #'symbolp)
                        "Syntax error in declaration ~s" decl)
             (setf types (collect-declared 'OBJECT decl-args types)))
            ((cl:OPTIMIZE cl:FTYPE cl:INLINE cl:NOTINLINE cl:DECLARATION SI::C-LOCAL
              SI::C-GLOBAL cl:DYNAMIC-EXTENT cl:VALUES
              SI::NO-CHECK-TYPE POLICY-DEBUG-IHS-FRAME :READ-ONLY)
             (push decl others))
            (SI:FUNCTION-BLOCK-NAME)
            (otherwise
             (if (or (alien-declaration-p decl-name)
                     (policy-declaration-p decl-name))
                 (push decl others)
                 (multiple-value-bind (ok type)
                     (if (machine-c-type-p decl-name)
                         (values t decl-name)
                         (valid-type-specifier decl-name))
                   (if (null ok)
                       (cmpwarn "Unknown declaration specifier ~s." decl-name)
                       (setf types (collect-declared type decl-args types)))))))
       finally (return (values body specials types ignored
                               (nreverse others) doc all-declarations)))))

(defun add-one-declaration (env decl)
  "Add to the environment one declarations which is not type, ignorable or
special variable declarations, as these have been extracted before."
  (case (car decl)
    (cl:OPTIMIZE
     (cmp-env-add-optimizations (rest decl) env))
    (POLICY-DEBUG-IHS-FRAME
     (let ((flag (or (rest decl) '(t))))
       (if *current-function*
           (progn
             (cmp-env-add-declaration 'policy-debug-ihs-frame flag
                                      (fun-cmp-env *current-function*))
             env)
           (cmp-env-add-declaration 'policy-debug-ihs-frame
                                    flag env))))
    (cl:FTYPE
     (if (atom (rest decl))
         (cmpwarn "Syntax error in declaration ~a" decl)
         (multiple-value-bind (type-name args)
             (si::normalize-type (second decl) env)
           (if (eq type-name 'FUNCTION)
               (dolist (v (cddr decl))
                 (setf env (add-function-declaration v args env)))
               (cmpwarn "In an FTYPE declaration, found ~A which is not a function type."
                        (second decl)))))
     env)
    (cl:INLINE
      (loop for name in (rest decl) do (setf env (declare-inline name env)))
      env)
    (cl:NOTINLINE
      (loop for name in (rest decl) do (setf env (declare-notinline name env)))
      env)
    (cl:DECLARATION
     (validate-alien-declaration (rest decl) #'cmperr)
     (cmp-env-extend-declaration 'alien (rest decl) env si:*alien-declarations*))
    ((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE :READ-ONLY)
     env)
    ((cl:DYNAMIC-EXTENT cl:IGNORABLE SI:FUNCTION-BLOCK-NAME)
     ;; FIXME! SOME ARE IGNORED!
     env)
    (otherwise
     (cond ((alien-declaration-p (first decl) env)
            env)
           ((maybe-add-policy decl env))
           (t
            (cmpwarn "Unknown declaration specifier ~s" (first decl))
            env)))))

(defun symbol-macro-declaration-p (name type)
  (ext:when-let ((record (cmp-env-search-symbol-macro name)))
    (let* ((expression (funcall record name nil)))
      (cmp-env-register-symbol-macro name `(the ,type ,expression)))
    t))

(defun check-vdecl (vnames ts is)
  (loop for (name . type) in ts
     unless (or (member name vnames :test #'eq)
                (symbol-macro-declaration-p name type)
                (cmp-env-search-var name))
     do (cmpwarn "Declaration of type~&~4T~A~&was found for not bound variable ~s."
                 type name))
  (loop for (name . expected-uses) in is
     unless (or (member name vnames :test #'eq)
                (cmp-env-search-symbol-macro name)
                (cmp-env-search-macro name))
     do (cmpwarn (if (minusp expected-uses)
                     "IGNORE declaration was found for not bound variable ~s."
                     "IGNORABLE declaration was found for not bound variable ~s.")
                 name)))
