source: branches/tfe/ccl/compiler/tfe/tenv.lisp @ 6563

(in-package "CCL")

;;; This should return a VAR (local to/inherited by the current
;;; lambda definition), an indication of whether that VAR was inherited
;;; (true) or local (false), and an indication of whether a CATCH
;;; was established between the variable's binding and this reference.
(defun tenv-find-lexical-variable (name env)
  (do* ((e env (lexenv.parent-env e)))
       ((or (null e) (eq (%svref e 0) 'definition-environment))
        (error "Bug: lexical variable ~s not found" name))
    (let* ((vars (lexenv.variables e)))
      (unless (atom vars)
        (dolist (v vars)
          (when (eq (var-name v) name)
            (return-from tenv-find-lexical-variable v)))))))

(defun tenv-note-lexref (ref var)
  (let* ((bind-node (var-refs var)))
    (when bind-node
      (let* ((last (tbind-refs bind-node)))
        (setf (tlexref-next ref) last
              (tbind-refs bind-node) ref)))))

(defun tenv-note-setq (set var)
  (let* ((bind-node (var-refs var)))
    (when bind-node
      (let* ((last (tbind-sets bind-node)))
        (setf (tsetq-lexical-next set) last
              (tbind-sets bind-node) set)))))

(defun tenv-effect-vdecls (pending sym env)
  (let ((vdecls (lexenv.vdecls env))
        (own nil))
    (dolist (decl (pending-declarations-vdecls pending) (setf (lexenv.vdecls env) vdecls))
      (when (eq (car decl) sym) 
        (push decl vdecls)
        (push (cdr decl) own)))
    own))

(defun tenv-need-sym (sym)
  (if (typep sym 'symbol)
    sym
    (error "~S is not a symbol" sym)))

(defun tenv-need-var (sym env)
  (let* ((sym (tenv-need-sym sym)))
    (if (constantp sym env)
      (error "Can't bind or assign to constant ~s." sym)
      sym)))
  
;;; Returns the new variable.
(defun tenv-init-var (pending var env)
  (let* ((sym (var-name var))
         (bits (%i+ (if (nx-proclaimed-special-p sym)
                      (if (nx-proclaimed-parameter-p sym)
                        (%ilogior (ash -1 $vbitspecial) (%ilsl $vbitparameter 1))
                        (ash -1 $vbitspecial))
                      0)
                    (if (proclaimed-ignore-p sym) (%ilsl $vbitignore 1) 0))))
    (push var (lexenv.variables env))
    (dolist (decl (tenv-effect-vdecls pending sym env))
      (case (car decl)
        (special (setq bits (%ilogior bits (ash -1 $vbitspecial) (%ilsl $vbitparameter 1))))
        (ignore (setq bits (%ilogior bits (%ilsl $vbitignore 1))))
        (ignore-if-unused (setq bits (%ilogior bits (%ilsl $vbitignoreunused 1))))
        (dynamic-extent (setq bits (%ilogior bits (%ilsl $vbitdynamicextent 1))))))
    (setf (var-bits var) bits)
    var))

(defun tenv-new-var (pending sym env)
  (tenv-init-var pending (cons-var (tenv-need-var sym env) 0) env))

(defun tenv-new-temp-var (env)
  (push (cons-var (gensym) 0) (lexenv.variables env)))



;;; Try to add declarations that aren't already in effect to the
;;; (innermost contour of) the environment; declarations that
;;; apply to bindings might already have been added to any contour
;;; between inner-env (inclusive) and outer-env (exclusive).
;;; Maintaining separate contours for each binding lets us
;;; capture the bindings/declarations in effect for each initform,
;;; but makes stuff like this complicated.
;;; Type declarations that aren't associated with a (current)
;;; binding might refine an already-extant declaration, so
;;; it's necesary to do a type intersection
(defun tenv-effect-other-decls (pending inner-env outer-env)
  (flet ((vdecl-exists (v)
           (do* ((e inner-env (lexenv.parent-env e)))
                ((eq e outer-env))
             (if (member v (lexenv.vdecls e))
               (return t))))
         (fdecl-exists (f)
           (do* ((e inner-env (lexenv.parent-env e)))
                ((eq e outer-env))
             (if (member f (lexenv.fdecls e))
               (return t)))))
    (dolist (f (pending-declarations-fdecls pending))
      (unless (fdecl-exists f)
        (push f (lexenv.fdecls inner-env))))
    (dolist (m (pending-declarations-mdecls pending))
      (push m (lexenv.mdecls inner-env)))
    (dolist (v (pending-declarations-vdecls pending))
      (unless (vdecl-exists v)
        (when (eq (cadr v) 'type)
          (let* ((sym (car v))
                 (other-decls
                  (nth-value 2 (variable-information sym inner-env)))
                 (otype (dolist (o other-decls)
                          (when (eq (cadr o) 'type)
                            (return o)))))
            (when otype
              (multiple-value-bind (intersection sure)
                  (type-intersection (specifier-type (cddr otype))
                                     (specifier-type (cddr v)))
                (when sure
                  (if (eq intersection *empty-type*)
                    (warn "Conflicting type declarations for ~s" sym)
                    (rplacd (cdr v) (type-specifier intersection))))))))
        (push v (lexenv.vdecls inner-env))))))

;;; The "bits" field of a VAR may point back to the "parent" (the var
;;; in some ancestor function that the current function (and all intervening
;;; functions) "inherits".
(defun tenv-var-bits (var)
  (do* ((var var bits)
        (bits (var-bits var) (var-bits var)))
       ((fixnump bits) bits)))

(defun tenv-check-var-usage (var)
  (let* ((bits (tenv-var-bits var)))
    (declare (fixnum bits))
    (unless (or (logbitp $vbitspecial bits)
                (logbitp $vbitignorable bits))
      (let* ((bind (var-refs var)))
        (when bind                      ; shouldn't this always exist ?
          (let* ((refs (tbind-refs bind))
                 (sets (tbind-sets bind)))
            (if (logbitp $vbitignore bits)
              (if (or refs sets)
                (warn "Variable ~s not ignored" (var-name var)))
              (unless refs
                (warn "Unused lexical variable ~s" (var-name var))))))))))

(defun tenv-check-env-var-usage (inner-env outer-env)
  (do* ((env inner-env (lexenv.parent-env env)))
       ((eq env outer-env))
    (let* ((vars (lexenv.variables env)))
      (unless (atom vars)
        (dolist (v vars) (tenv-check-var-usage v))))))

;;; Pending declarations
(defstruct tenv-pending-declarations
  vdecls
  fdecls
  mdecls)

(defvar *tenv-standard-declaration-handlers* ())

(defun tenv-bad-decls (decl)
  (tgen-warn "Invalid declaration: ~s" decl))

(defmacro deftenvdecl (sym lambda-list &body forms)
  (multiple-value-bind (body decls) (parse-body forms nil t)
    `(setf (getf *tenv-standard-declaration-handlers* ',sym )
           (function (lambda ,lambda-list
                       ,@decls
                       ,@body)))))

(deftenvdecl special (pending decl env)
  (declare (ignore env))
  (dolist (s (%cdr decl))
    (if (symbolp s) 
      (tenv-new-vdecl pending s 'special)
      (tenv-bad-decls decl))))

(deftenvdecl dynamic-extent (pending decl env)
  (declare (ignore env))
  (dolist (s (%cdr decl))
    (if (symbolp s) 
      (tenv-new-vdecl pending s 'dynamic-extent t)
      (if (and (consp s)
               (eq (%car s) 'function)
               (consp (%cdr s))
               (valid-function-name-p (cadr s))
               (setq s (validate-function-name (cadr s))))
        (tenv-new-fdecl pending s 'dynamic-extent t)
        (tenv-bad-decls decl)))))

(deftenvdecl ignorable (pending decl env)
  (declare (ignore env))
  (dolist (s (%cdr decl))
    (if (symbolp s) 
      (tenv-new-vdecl pending s 'ignore-if-unused t)
      (if (and (consp s)
               (eq (%car s) 'function)
               (consp (%cdr s))
               (valid-function-name-p (cadr s))
               (setq s (validate-function-name (cadr s))))
        (tenv-new-fdecl pending s 'ignore-if-unused t)
        (tenv-bad-decls decl)))))

(deftenvdecl ftype (pending decl env)
  (declare (ignore env))
  (destructuring-bind (type &rest fnames) (%cdr decl)
    (dolist (s fnames)
      (tenv-new-fdecl pending s 'ftype type))))

(deftenvdecl settable (pending decl env)
  (tenv-settable-decls pending decl env t))

(deftenvdecl unsettable (pending decl env)
  (tenv-settable-decls pending decl env nil))

(defun tenv-settable-decls (pending decl env val)
  (declare (ignore env))
  (dolist (s (%cdr decl))
    (if (symbolp s)
      (tenv-new-vdecl pending s 'settable val)
      (tenv-bad-decls decl))))

(deftenvdecl type (pending decl env)
  (declare (ignore env))
  (let* ((spec (%cdr decl))
         (type (car spec))
         (ctype (specifier-type type)))
    (unless (typep ctype 'unknown-ctype)
      (dolist (sym (cdr spec))
        (if (symbolp sym)
          (tenv-new-vdecl pending sym 'type (type-specifier ctype))
          (tenv-bad-decls decl))))))

(defun tenv-inline-decl (pending decl val &aux valid-name)
  (dolist (s (%cdr decl))
    (multiple-value-setq (valid-name s) (valid-function-name-p s))
    (if valid-name
      (progn
        (if (tenv-self-call-p s nil t)
          (setq *tenv-inlined-self* val))
        (tenv-new-fdecl pending s 'inline (if val 'inline 'notinline)))
      (tenv-bad-decls decl))))

(deftenvdecl inline (pending decl env)
  (declare (ignore env))
  (tenv-inline-decl pending decl t))

(deftenvdecl notinline (pending decl env)
  (declare (ignore env))
  (tenv-inline-decl pending decl nil))


(defun tenv-new-vdecl (pending name class &optional info)
  (push (cons name (cons class info)) (tenv-pending-declarations-vdecls pending)))

(defun tenv-new-fdecl (pending name class &optional info)
  (push (cons name (cons class info)) (tenv-pending-declarations-fdecls pending)))

(defun tenv-new-mdecl (pending name class &optional info)
  (push (cons name (cons class info)) (tenv-pending-declarations-mdecls pending)))



(provide "TENV")