Changeset 13214

Nov 18, 2009, 7:17:43 PM (10 years ago)

Extend find-ftype-decl so it can get different decls depending on the actual args, and made it do so in a few cases (including aref/uvref, so nx-form-type doesn't have to special-case them anymore).

3 edited


  • branches/working-0711/ccl

  • branches/working-0711/ccl/compiler/nx-basic.lisp

    r13197 r13214  
    352352    (if decl (%cdr decl) t)))
    354 (defun nx-declared-result-type (sym &optional (env *nx-lexical-environment*))
     354(defun nx-declared-result-type (sym &optional (env *nx-lexical-environment*) args)
    355355  (when (symbolp (setq sym (maybe-setf-function-name sym)))
    356     (let* ((ftype (find-ftype-decl sym env))
    357            (ctype (if (typep ftype 'ctype) ftype (specifier-type-if-known ftype env))))
     356    (let* ((ftype (find-ftype-decl sym env args))
     357           (ctype (and ftype (if (typep ftype 'ctype) ftype (specifier-type-if-known ftype env)))))
    358358      (unless (or (null ctype)
    359359                  (not (function-ctype-p ctype))
  • branches/working-0711/ccl/compiler/nx0.lisp

    r13165 r13214  
    19851985        (ftype nil)
    19861986        (def nil))
    1987     (setq ftype (find-ftype-decl sym env))
     1987    (setq ftype (find-ftype-decl sym env args spread-p))
    19881988    (setq def (nx1-find-call-def sym env global-only))
    19891989    (when ftype
    20152015    (values errors-p typed-args result-type)))
    2017 (defun find-ftype-decl (sym &optional (env *nx-lexical-environment*))
     2017(defun known-ftype-for-call (sym args spread-p env)
     2018  ;; Find ftype based on actual arguments.
     2019  ;; This should be more general, but for now just pick off some special cases..
     2020  (when (and args (or (not spread-p) (cdr args)))
     2021    (cond ((or (eq sym 'aref) (eq sym 'uvref))
     2022           (let* ((atype (nx-form-type (car args) env))
     2023                  (a-ctype (specifier-type atype)))
     2024             (when (array-ctype-p a-ctype)
     2025               ;; No point declaring the type of an arg whose type we already know
     2026               `(function (t &rest integer) ,(type-specifier (array-ctype-specialized-element-type
     2027                                                                  a-ctype))))))
     2028          ((eq sym 'error)
     2029           (let ((condition (car args)))
     2030             (cond ((nx-form-typep condition 'condition env)
     2031                    '(function (t) *))
     2032                   ((nx-form-typep condition 'symbol env)
     2033                    ;; TODO: might be able to figure out actual initargs...
     2034                    `(function (t &key &allow-other-keys) *))
     2035                   (t nil))))
     2036          ((eq sym 'cerror)
     2037           (when (and (cdr args) (or (not spread-p) (cddr args)))
     2038             (let ((condition (cadr args)))
     2039               (cond ((nx-form-typep condition 'condition env)
     2040                      `(function (string t &rest t) *))
     2041                     ((nx-form-typep condition 'symbol env)
     2042                      `(function (string t &key &allow-other-keys) *))
     2043                     (t `(function (string t &rest t) *))))))
     2044          (t nil))))
     2046(defun find-ftype-decl (sym &optional (env *nx-lexical-environment*) (args :unknown) spread-p)
    20182047  (setq sym (maybe-setf-function-name sym))
    20192048  (loop
    2020     (when (listp env) (return  (proclaimed-ftype sym)))
    2021     (dolist (fdecl (lexenv.fdecls env))
    2022       (when (and (eq (car fdecl) sym)
    2023                  (eq (car (%cdr fdecl)) 'ftype))
    2024         (return-from find-ftype-decl (%cddr fdecl))))
    2025     (when (and (istruct-typep env 'lexical-environment)
    2026                (assq sym (lexenv.functions env)))
    2027       (return-from find-ftype-decl nil))
    2028     (setq env (lexenv.parent-env env))))
     2049    for lexenv = env then (lexenv.parent-env lexenv) until (listp lexenv)
     2050    do (dolist (fdecl (lexenv.fdecls lexenv))
     2051         (when (and (eq (car fdecl) sym)
     2052                    (eq (car (%cdr fdecl)) 'ftype))
     2053           (return-from find-ftype-decl (%cddr fdecl))))
     2054    do (when (and (istruct-typep lexenv 'lexical-environment)
     2055                  (assq sym (lexenv.functions lexenv)))
     2056         (return-from find-ftype-decl nil)))
     2057  (or (proclaimed-ftype sym)
     2058      (and (listp args)
     2059           (known-ftype-for-call sym args spread-p env))))
    20302061(defun nx1-analyze-ftyped-call (ftype sym arglist spread-p env)
    26342665                      #+no (and (memq (car form) *logical-ops*)
    26352666                           (grovel-logical-form form env))
    2636                       (nx-declared-result-type (%car form) env)
    2637                       ;; Sort of the right idea, but this should be done
    2638                       ;; in a more general way.
    2639                       (when (or (eq (car form) 'aref)
    2640                                 (eq (car form) 'uvref))
    2641                         (let* ((atype (nx-form-type (cadr form) env))
    2642                                (a-ctype (specifier-type atype)))
    2643                           (when (array-ctype-p a-ctype)
    2644                             (type-specifier (array-ctype-specialized-element-type
    2645                                              a-ctype)))))
     2667                      (nx-declared-result-type (%car form) env (%cdr form))
    26462668                      t))))
    26472669            t))
Note: See TracChangeset for help on using the changeset viewer.