Ignore:
Timestamp:
Aug 1, 2009, 3:50:08 PM (10 years ago)
Author:
gz
Message:

ftypes - r12467/r12500/r12512/r12514 from trunk

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/nx0.lisp

    r12412 r12515  
    739739                    (rplacd (cdr decl) merged-type))))
    740740              (push decl env-vdecls)))))
    741       (when fdecls (setf (lexenv.fdecls env) (merge-decls fdecls (lexenv.vdecls env))))
     741      (when fdecls (setf (lexenv.fdecls env) (merge-decls fdecls (lexenv.fdecls env))))
    742742      (when mdecls (setf (lexenv.mdecls env) (merge-decls mdecls (lexenv.mdecls env))))
    743743      (setq *nx-inlined-self* (and (nx-self-calls-inlineable env)
     
    816816(defnxdecl ftype (pending decl env &aux whined)
    817817  (destructuring-bind (type &rest fnames) (%cdr decl)
    818     (if (specifier-type-if-known type env)
    819       (dolist (s fnames)
    820         (if (or (symbolp s) (setf-function-name-p s))
    821             (nx-new-fdecl pending s 'ftype type)
    822             (unless (shiftf whined t) (nx-bad-decls decl))))
    823       (nx1-whine :unknown-type-in-declaration type))))
     818    (let ((ctype (specifier-type-if-known type env)))
     819      (if (null ctype)
     820        (nx1-whine :unknown-type-in-declaration type)
     821        (if (types-disjoint-p ctype (specifier-type 'function))
     822          (nx-bad-decls decl)
     823          (dolist (s fnames)
     824            (if (or (symbolp s) (setf-function-name-p s))
     825              (nx-new-fdecl pending s 'ftype type)
     826              (unless (shiftf whined t) (nx-bad-decls decl)))))))))
    824827
    825828(defnxdecl settable (pending decl env)
     
    18461849        (push warning (afunc-warnings p))))))
    18471850
    1848 (defun nx1-type-intersect (form type1 type2 &optional env)
    1849   (declare (ignore env)) ; use it when deftype records info in env.  Fix this then ...
    1850   (let* ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1)))
    1851          (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2)))
     1851(defun nx1-type-intersect (form type1 type2 &optional (env *nx-lexical-environment*))
     1852  (let* ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1 env)))
     1853         (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2 env)))
    18521854         (intersection (type-intersection ctype1 ctype2)))
    1853     (if (eq intersection *empty-type*)
     1855    (when (eq intersection *empty-type*)
    18541856      (let ((type1 (if (typep type1 'ctype)
    18551857                     (type-specifier type1)
     
    18601862        (nx1-whine :type-conflict form type1 type2)))
    18611863    (type-specifier intersection)))
    1862                  
    1863 
    18641864
    18651865(defun nx-declared-notinline-p (sym env)
     
    19001900  (nx1-typed-call (car args) (%cdr args)))
    19011901
    1902 (defun nx1-typed-call (sym args)
    1903   (multiple-value-bind (type errors-p) (nx1-call-result-type sym args)
    1904     (let ((form (nx1-call sym args nil nil errors-p)))
    1905       (if (eq type t)
     1902(defun nx1-typed-call (fn args &optional spread-p)
     1903  (let ((global-only nil)
     1904        (errors-p nil)
     1905        (result-type t))
     1906    (when (and (acode-p fn) (eq (acode-operator fn) (%nx1-operator immediate)))
     1907      (multiple-value-bind (valid name) (valid-function-name-p (%cadr fn))
     1908        (when valid
     1909          (setq fn name global-only t))))
     1910    (when (non-nil-symbol-p fn)
     1911      (multiple-value-setq (errors-p args result-type)
     1912        (nx1-check-typed-call fn args spread-p global-only)))
     1913    (setq result-type (nx1-type-intersect fn *nx-form-type* result-type))
     1914    (let ((form (nx1-call fn args spread-p global-only errors-p)))
     1915      (if (eq result-type t)
    19061916        form
    1907         (make-acode (%nx1-operator typed-form) type form)))))
     1917        (make-acode (%nx1-operator typed-form) result-type form)))))
    19081918
    19091919(defvar *format-arg-functions* '((format . 1) (format-to-string . 1) (error . 0) (warn . 0)
     
    19181928                                 (compiler-bug . 0)))
    19191929
    1920 ;;; Wimpy.
    1921 (defun nx1-call-result-type (sym &optional (args nil args-p) spread-p global-only)
    1922   (let* ((env *nx-lexical-environment*)
    1923          (global-def nil)
    1924          (lexenv-def nil)
    1925          (defenv-def nil)
    1926          (somedef nil)
    1927          (whined nil))
    1928     (when (and sym
    1929                (symbolp sym)
    1930                (not (find-ftype-decl sym env))
    1931                (or global-only
    1932                    (not (setq lexenv-def (nth-value 1 (nx-lexical-finfo sym)))))
    1933                (null (setq defenv-def (retrieve-environment-function-info sym env)))
    1934                (neq sym *nx-global-function-name*)
    1935                (not (functionp (setq global-def (fboundp sym)))))
    1936       (if args-p
    1937         (nx1-whine :undefined-function sym args spread-p)
    1938         (nx1-whine :undefined-function sym))
    1939       (setq whined t))
    1940     (when (and args-p
    1941                (not spread-p)
    1942                (setq somedef (unless lexenv-def (cdr (assq sym *format-arg-functions*))))
    1943                (setq somedef (nthcdr somedef args))
    1944                (stringp (car somedef)))
    1945       (when (nx1-check-format-call (car somedef) (cdr somedef) env)
    1946         (setq whined t)))
    1947     (when (and args-p (setq somedef (or lexenv-def defenv-def (if (typep global-def 'function) global-def))))
    1948       (multiple-value-bind (deftype reason)
    1949           (nx1-check-call-args somedef args spread-p)
    1950         (when deftype
    1951           (nx1-whine deftype sym reason args spread-p)
    1952           (setq whined t))))
    1953     (values (nx-target-type *nx-form-type*) whined)))
    1954 
    1955 (defun find-ftype-decl (sym env)
     1930(defun nx1-find-call-def (sym &optional (env *nx-lexical-environment*) (global-only nil))
     1931  (and (or (and (not global-only) (nth-value 1 (nx-lexical-finfo sym)))
     1932           (retrieve-environment-function-info sym env)
     1933           (let ((def (fboundp sym)))
     1934             (and (functionp def) def)))))
     1935
     1936(defun nx1-check-typed-call (sym args &optional spread-p global-only)
     1937  (let ((env *nx-lexical-environment*)
     1938        (result-type t)
     1939        (typed-args args)
     1940        (errors-p nil)
     1941        (ftype nil)
     1942        (def nil))
     1943    (setq ftype (find-ftype-decl sym env))
     1944    (setq def (nx1-find-call-def sym env global-only))
     1945    (when ftype
     1946      (multiple-value-setq (typed-args result-type errors-p)
     1947        (nx1-analyze-ftyped-call ftype sym args spread-p env)))
     1948    (when (and def (not errors-p))
     1949      (multiple-value-bind (deftype reason) (nx1-check-call-args def args spread-p)
     1950        (when deftype
     1951          (nx1-whine deftype sym reason args spread-p)
     1952          (setq errors-p t))))
     1953    (unless (or def ftype (eq sym *nx-global-function-name*))
     1954      (nx1-whine :undefined-function sym args spread-p)
     1955      (setq errors-p t))
     1956    (unless errors-p
     1957      (let* ((format-args (and (not spread-p)
     1958                               (not (typep def 'afunc))
     1959                               (let* ((n (cdr (assq sym *format-arg-functions*))))
     1960                                 (and n (nthcdr n typed-args)))))
     1961             (control (pop format-args)))
     1962        (when (and (consp control)
     1963                   (eq (%car control) 'the)
     1964                   (consp (%cdr control))
     1965                   (consp (%cddr control)))
     1966          (setq control (%caddr control)))
     1967        (when (stringp (setq control (nx-transform control env)))
     1968          (when (nx1-check-format-call control format-args env)
     1969            (setq errors-p t)))))
     1970
     1971    (values errors-p typed-args result-type)))
     1972
     1973(defun find-ftype-decl (sym &optional (env *nx-lexical-environment*))
    19561974  (setq sym (maybe-setf-function-name sym))
    19571975  (loop
     
    19601978                   (proclaimed-ftype sym))))
    19611979    (dolist (fdecl (lexenv.fdecls env))
    1962       (declare (list fdecl))
    19631980      (when (and (eq (car fdecl) sym)
    1964                  (eq (car (the list (cdr fdecl))) 'ftype))
    1965         (return-from find-ftype-decl (cdr (the list (cdr fdecl))))))
     1981                 (eq (car (%cdr fdecl)) 'ftype))
     1982        (return-from find-ftype-decl (%cddr fdecl))))
    19661983    (setq env (lexenv.parent-env env))))
     1984
     1985(defun nx1-analyze-ftyped-call (ftype sym arglist spread-p env)
     1986  (let ((ctype (if (typep ftype 'ctype) ftype (specifier-type ftype)))
     1987        (result-type t)
     1988        (errors-p nil))
     1989    (unless (or (null ctype) (not (function-ctype-p ctype)))
     1990      (unless (function-ctype-wild-args ctype)
     1991        (let ((req (args-ctype-required ctype))
     1992              (opt (args-ctype-optional ctype))
     1993              (rest (args-ctype-rest ctype))
     1994              (keyp (args-ctype-keyp ctype))
     1995              (aokp (or spread-p (args-ctype-allowp ctype)))
     1996              (keys (args-ctype-keywords ctype))
     1997              (typed-arglist nil)
     1998              (key-type nil)
     1999              (bad-keys nil)
     2000              (nargs (if spread-p (1- (length arglist)) (length arglist))))
     2001          (flet ((collect-type (arg type)
     2002                   (push (if (and type (neq type *universal-type*) (neq type *wild-type*))
     2003                           `(the ,(type-specifier type) ,arg)
     2004                           arg)
     2005                         typed-arglist))
     2006                 (key-name (x) (key-info-name x))
     2007                 (whine (&rest reason)
     2008                   (nx1-whine :ftype-mismatch sym reason arglist spread-p)
     2009                   (setq errors-p t)))
     2010            (declare (dynamic-extent #'collect-type #'whine))
     2011            (loop for arg in arglist as i below nargs
     2012                  do (cond
     2013                       (req (collect-type arg (pop req)))
     2014                       (opt (collect-type arg (pop opt)))
     2015                       (rest (collect-type arg rest))
     2016                       (key-type (collect-type arg (shiftf key-type nil)))
     2017                       (keyp (if (nx-form-constant-p arg env)
     2018                               (let* ((key (nx-form-constant-value arg env))
     2019                                      (ki (find key keys :key #'key-name)))
     2020                                 (when (eq key :allow-other-keys) (setq aokp t))
     2021                                 (if ki
     2022                                   (setq key-type (key-info-type ki))
     2023                                   (unless aokp (push key bad-keys))))
     2024                               (setq aokp t))
     2025                             (collect-type arg nil)
     2026                             (unless key-type (setq key-type *universal-type*)))
     2027                       (t (return (whine :toomany
     2028                                         nargs
     2029                                         (+ (length (args-ctype-required ctype))
     2030                                            (length (args-ctype-optional ctype)))))))
     2031                  finally (cond (spread-p (collect-type arg nil))
     2032                                (req (whine :toofew
     2033                                            nargs
     2034                                            (length (args-ctype-required ctype))))
     2035                                (key-type (whine :odd-keywords
     2036                                                 (nthcdr
     2037                                                  (+ (length (args-ctype-required ctype))
     2038                                                     (length (args-ctype-optional ctype)))
     2039                                                  arglist)))
     2040                                (bad-keys (whine :unknown-keyword
     2041                                                 (if (cdr bad-keys)
     2042                                                   (nreverse bad-keys)
     2043                                                   (car bad-keys))
     2044                                                 (map 'list #'key-name keys)))))
     2045            (unless errors-p
     2046              (setq arglist (nreverse typed-arglist))))))
     2047      (setq result-type (type-specifier (single-value-type (function-ctype-returns ctype)))))
     2048    (values arglist (nx-target-type result-type) errors-p)))
     2049
    19672050
    19682051(defun innermost-lfun-bits-keyvect (def)
     
    19962079                                (if (lambda-expression-p lambda-form)
    19972080                                  (encode-lambda-list (cadr lambda-form))))))
    1998       (when bits
    1999         (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
    2000         (let* ((nargs (length arglist))
    2001                (minargs (if spread-p (1- nargs) nargs))
    2002                (maxargs (if spread-p nil nargs))
    2003                (required (ldb $lfbits-numreq bits))
    2004                (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
    2005                       nil
    2006                       (+ required (ldb $lfbits-numopt bits)))))
    2007           ;; If the (apparent) number of args in the call doesn't
    2008           ;; match the definition, complain.  If "spread-p" is true,
    2009           ;; we can only be sure of the case when more than the
    2010           ;; required number of args have been supplied.
    2011           (if (or (if (and (not spread-p) (< minargs required))
    2012                     (setq reason `(:toofew ,minargs ,required)))
    2013                   (if (and max (or (> minargs max)) (if maxargs (> maxargs max)))
    2014                     (setq reason (list :toomany (if (> minargs max) minargs maxargs) max)))
    2015                   (setq reason (nx1-find-bogus-keywords arglist spread-p bits keyvect)))
    2016             (values deftype reason)))))))
    2017 
    2018 (defun nx1-find-bogus-keywords (args spread-p bits keyvect)
     2081      (setq reason (nx1-check-call-bits bits keyvect arglist spread-p))
     2082      (when reason
     2083        (values deftype reason)))))
     2084
     2085(defun nx1-check-call-bits (bits keyvect arglist spread-p)
     2086  (when bits
     2087    (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
     2088    (let* ((env *nx-lexical-environment*)
     2089           (nargs (length arglist))
     2090           (minargs (if spread-p (1- nargs) nargs))
     2091           (required (ldb $lfbits-numreq bits))
     2092           (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
     2093                  nil
     2094                  (+ required (ldb $lfbits-numopt bits)))))
     2095      ;; If the (apparent) number of args in the call doesn't
     2096      ;; match the definition, complain.  If "spread-p" is true,
     2097      ;; we can only be sure of the case when more than the
     2098      ;; required number of args have been supplied.
     2099      (or (and (not spread-p)
     2100               (< minargs required)
     2101               `(:toofew ,minargs ,required))
     2102          (and max
     2103               (> minargs max)
     2104               (list :toomany nargs max))
     2105          (nx1-find-bogus-keywords arglist spread-p bits keyvect env)))))
     2106
     2107(defun nx1-find-bogus-keywords (args spread-p bits keyvect env)
    20192108  (declare (fixnum bits))
    20202109  (when (logbitp $lfbits-aok-bit bits)
     
    20222111  (when (and (logbitp $lfbits-keys-bit bits)
    20232112             (not spread-p))     ; Can't be sure, last argform may contain :allow-other-keys
    2024     (do* ((key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
     2113    (do* ((bad-keys nil)
     2114          (key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
    20252115          (key-args key-values  (cddr key-args)))
    2026          ((null key-args))
    2027       (if (null (cdr key-args))
    2028         (return (list :odd-keywords key-values))
    2029         (when keyvect
    2030           (let* ((keyword (%car key-args)))
    2031             (unless (constantp keyword)
    2032               (return nil))
    2033             (unless (eq keyword :allow-other-keys)
    2034               (unless (position (nx-unquote keyword) keyvect)               
    2035                 (return (list :unknown-keyword
    2036                               (nx-unquote keyword)
    2037                               (coerce keyvect 'list)))))))))))
     2116         ((null key-args)
     2117          (when (and keyvect bad-keys)
     2118            (list :unknown-keyword
     2119                  (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys))
     2120                  (coerce keyvect 'list))))
     2121      (unless (cdr key-args)
     2122        (return (list :odd-keywords key-values)))
     2123      (when keyvect
     2124        (let* ((keyword (%car key-args)))
     2125          (unless (nx-form-constant-p keyword env)
     2126            (return nil))
     2127          (setq keyword (nx-form-constant-value keyword env))
     2128          (if (eq keyword :allow-other-keys)
     2129            (setq keyvect nil)
     2130            (unless (position keyword keyvect)
     2131              (push keyword bad-keys))))))))
    20382132
    20392133;;; we can save some space by going through subprims to call "builtin"
     
    20682162(defun nx1-call (sym args &optional spread-p global-only inhibit-inline)
    20692163  (nx1-verify-length args 0 nil)
     2164  (when (and (acode-p sym) (eq (acode-operator sym) (%nx1-operator immediate)))
     2165    (multiple-value-bind (valid name) (valid-function-name-p (%cadr sym))
     2166      (when valid
     2167        (setq global-only t sym name))))
    20702168  (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*))))
    20712169    (if (nx-self-call-p sym global-only)
     
    24132511(defun nx-form-type (form &optional (env *nx-lexical-environment*))
    24142512  (if (nx-form-constant-p form env)
    2415     (type-of (nx-form-constant-value form env))
     2513    ;(type-of (nx-form-constant-value form env))
     2514    `(member ,(nx-form-constant-value form env))
    24162515    (if (and (consp form)          ; Kinda bogus now, but require-type
    24172516             (eq (%car form) 'require-type) ; should be special some day
     
    24252524              (destructuring-bind (typespec val) (%cdr form)
    24262525                (declare (ignore val))
    2427                 (let* ((ctype (values-specifier-type typespec)))
    2428                   (if (typep ctype 'values-ctype)
    2429                     (let* ((req (values-ctype-required ctype)))
    2430                       (if req
    2431                         (nx-target-type (type-specifier (car req)))
    2432                         '*))
    2433                     (nx-target-type (type-specifier ctype)))))
     2526                (nx-target-type (type-specifier (single-value-type (values-specifier-type typespec)))))
    24342527              (if (eq (%car form) 'setq)
    2435                 (nx-declared-type (cadr form) env)
     2528                (let* ((args (%cdr form))
     2529                       (n (length args)))
     2530                  (if (and (evenp n)
     2531                           (> n 0)
     2532                           (setq args (nthcdr (- n 2) args))
     2533                           (non-nil-symbol-p (car args)))
     2534                    (nx1-type-intersect (%car args)
     2535                                        (nx-declared-type (%car args) env)
     2536                                        (nx-form-type (%cadr args) env)
     2537                                        env)
     2538                    t))
    24362539                (let* ((op (gethash (%car form) *nx1-operators*)))
    24372540                  (or (and op (cdr (assq op *nx-operator-result-types*)))
     
    24412544                      (and (memq (car form) *logical-ops*)
    24422545                           (grovel-logical-form form env))
     2546                      (nx-declared-result-type (%car form) env)
    24432547                      ;; Sort of the right idea, but this should be done
    24442548                      ;; in a more general way.
     
    24532557            t))
    24542558        t))))
     2559
    24552560
    24562561(defparameter *numeric-ops* '(+ -  / * +-2 --2 *-2 /-2))
     
    25882693(defun nx1-func-name (gizmo)
    25892694  (and (consp gizmo)
    2590        (or (eq (%car gizmo) 'function) (eq (%car gizmo) 'quote))
     2695       (eq (%car gizmo) 'function)
    25912696       (consp (%cdr gizmo))
    25922697       (null (%cddr gizmo))
    2593        (nth-value 1 (valid-function-name-p (%cadr gizmo)))))
     2698       (if (lambda-expression-p (%cadr gizmo))
     2699         (%cadr gizmo)
     2700         (nth-value 1 (valid-function-name-p (%cadr gizmo))))))
    25942701
    25952702; distinguish between program errors & incidental ones.
Note: See TracChangeset for help on using the changeset viewer.