Changeset 12515


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

ftypes - r12467/r12500/r12512/r12514 from trunk

Location:
branches/working-0711/ccl
Files:
9 edited

Legend:

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

    r12412 r12515  
    205205(%include "ccl:compiler;lambda-list.lisp")
    206206
    207 
     207#-BOOTSTRAPPED (unless (fboundp 'types-disjoint-p)
     208                 (fset 'types-disjoint-p (lambda (t1 t2 &optional env) t1 t2 env nil)))
    208209
    209210
     
    352353                     (assq sym *nx-proclaimed-types*))))
    353354    (if decl (%cdr decl) t)))
     355
     356(defun nx-declared-result-type (sym &optional (env *nx-lexical-environment*))
     357  (when (symbolp (setq sym (maybe-setf-function-name sym)))
     358    (let* ((ftype (find-ftype-decl sym env))
     359           (ctype (if (typep ftype 'ctype) ftype (specifier-type-if-known ftype env))))
     360      (unless (or (null ctype)
     361                  (not (function-ctype-p ctype))
     362                  (eq *wild-type* (function-ctype-returns ctype)))
     363        (let ((result-type (type-specifier (single-value-type (function-ctype-returns ctype)))))
     364          (and (neq result-type 't) result-type))))))
    354365
    355366(defmacro define-declaration (decl-name lambda-list &body body &environment env)
     
    598609       (destructuring-bind (badguy goodguys)
    599610           (cdr reason)
    600          (format stream "the keyword argument ~s is not one of ~s, which are recognized~&  by " badguy goodguys))))
     611         (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~s, which are recognized~&  by "
     612                 (consp badguy) badguy goodguys))))
    601613    (format stream
    602614            (ecase (compiler-warning-warning-type condition)       
     615              (:ftype-mismatch "the FTYPE declaration of ~s")
    603616              (:global-mismatch "the current global definition of ~s")
    604617              (:environment-mismatch "the definition of ~s visible in the current compilation unit.")
     
    621634    (:environment-mismatch . report-compile-time-argument-mismatch)
    622635    (:lexical-mismatch . report-compile-time-argument-mismatch)   
     636    (:ftype-mismatch . report-compile-time-argument-mismatch)
    623637    (:type . "Type declarations violated in ~S")
    624638    (:type-conflict . "Conflicting type declarations for ~S")
  • branches/working-0711/ccl/compiler/nx.lisp

    r12412 r12515  
    203203    (:lexical-mismatch . invalid-arguments)
    204204    (:environment-mismatch . invalid-arguments)
     205    (:ftype-mismatch . invalid-arguments)
    205206    (:ignore . style-warning)
    206207    (:result-ignored . style-warning)
  • 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.
  • branches/working-0711/ccl/compiler/nx1.lisp

    r12340 r12515  
    2828           (let* ((ctype (handler-case (values-specifier-type (nx-target-type typespec) env)
    2929                           (parse-unknown-type (c)
    30                                                (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
    31                                                nil)
     30                             (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
     31                             nil)
    3232                           (program-error (c)
    33                                           (nx1-whine :invalid-type typespec c)
    34                                           nil))))
    35              (if (or (null ctype) (typep ctype 'values-ctype))
     33                              (nx1-whine :invalid-type typespec c)
     34                              nil))))
     35             (if (null ctype)
    3636               '*
    3737               (if (typep ctype 'function-ctype)
    3838                 'function
    39                  (nx-target-type (type-specifier ctype)))))))
     39                 (nx-target-type (type-specifier (single-value-type ctype))))))))
    4040    (let* ((typespec (typespec-for-the typespec))
    4141           (*nx-form-type* typespec)
    4242           (transformed (nx-transform form env)))
    43       (when (and (nx-form-constant-p transformed env)
    44                  (not (typep (nx-form-constant-value transformed env) typespec)))
    45         (nx1-whine :type call)
    46         (setq typespec t))
    4743      (flet ((fold-the ()
    4844               (do* ()
     
    6359          (when (eq transformed last)
    6460            (return)))
     61        (when (and (nx-form-constant-p transformed env)
     62                   (not (typep (nx-form-constant-value transformed env) typespec)))
     63          (nx1-whine :type call)
     64          (setq typespec t))
     65        (setq typespec (nx-target-type
     66                        (or (nx1-type-intersect call
     67                                                typespec
     68                                                (typespec-for-the (nx-form-type transformed env)))
     69                            t)))
    6570        (make-acode
    6671         (%nx1-operator typed-form)
     
    11601165
    11611166
    1162 
    1163 
    1164                          
    1165 
    1166 (defnx1 nx1-apply ((apply)) (&whole call fn arg &rest args &aux (orig args) (spread-p t))
    1167   (if (null (%car (last (push arg args))))
    1168     (setq spread-p nil args (butlast args)))
    1169   (let ((name (nx1-func-name fn))
    1170         (global nil)
    1171         (result-type t))
    1172     (when name
    1173       (setq global (eq (%car fn) 'quote)
    1174             result-type (nx1-call-result-type name args spread-p global))
    1175       (if global (setq name (nx1-form fn))))
    1176     (if name
    1177       (unless global
    1178         (let*  ((afunc (nth-value 1 (nx-lexical-finfo name))))
    1179           (when (and afunc (eq afunc *nx-call-next-method-function*))
    1180             (setq name (if (or arg orig)
    1181                          '%call-next-method-with-args
    1182                          '%call-next-method)
    1183                          global t
    1184                          args (cons (var-name *nx-next-method-var*) args)))))
    1185       (setq name (nx1-form fn)))
    1186     (let* ((form (nx1-call name args spread-p global)))
    1187       (if (eq result-type t)
    1188         form
    1189         (make-acode (%nx1-operator typed-form) result-type form)))))
    1190 
    1191 (defnx1 nx1-%apply-lexpr ((%apply-lexpr)) (&whole call fn arg &rest args &aux (orig args))
    1192   (push arg args)
    1193   (let ((name (nx1-func-name fn))
    1194         (global nil))
    1195     (if name
    1196       (if (eq (%car fn) 'quote)
    1197         (setq global t name (nx1-form fn))
    1198         (let*  ((afunc (nth-value 1 (nx-lexical-finfo name))))
    1199           (when (and afunc (eq afunc *nx-call-next-method-function*))
    1200             (setq name (if (or arg orig)
    1201                          '%call-next-method-with-args
    1202                          '%call-next-method)
    1203                   global t
    1204                   args (cons (var-name *nx-next-method-var*) args)))))
    1205       (setq name (nx1-form fn)))
    1206     (nx1-call name args 0 global)))
    1207 
     1167(defnx1 nx1-apply ((apply)) (&whole call fn arg &rest args &environment env)
     1168  (let ((last (%car (last (push arg args)))))
     1169    (if (and (nx-form-constant-p last env)
     1170             (null (nx-form-constant-value last env)))
     1171      (nx1-form (let ((new `(funcall ,fn ,@(butlast args))))
     1172                  (nx-note-source-transformation call new)
     1173                  new))
     1174      (nx1-apply-fn fn args t))))
     1175
     1176(defnx1 nx1-%apply-lexpr ((%apply-lexpr)) (fn arg &rest args)
     1177  (nx1-apply-fn fn (cons arg args) 0))
     1178
     1179(defun nx1-apply-fn (fn args spread)
     1180  (let* ((sym (nx1-func-name fn))
     1181         (afunc (and (non-nil-symbol-p sym) (nth-value 1 (nx-lexical-finfo sym)))))
     1182    (when (and afunc (eq afunc *nx-call-next-method-function*))
     1183      (setq fn (let ((new (list 'quote (if (or (car args) (cdr args))
     1184                                         '%call-next-method-with-args
     1185                                         '%call-next-method))))
     1186                 (nx-note-source-transformation fn new)
     1187                 new)
     1188            sym nil
     1189            args (cons (var-name *nx-next-method-var*) args)))
     1190    (nx1-typed-call (if (non-nil-symbol-p sym) sym (nx1-form fn)) args spread)))
    12081191
    12091192
     
    12811264             (setq symbol (cadr sym))
    12821265             (symbolp symbol))
    1283       (progn
    1284         (nx1-call-result-type symbol)   ; misnamed.  Checks for (un-)definedness.
     1266      (let ((env *nx-lexical-environment*))
     1267        (unless (or (nx1-find-call-def symbol env)
     1268                    (find-ftype-decl symbol env)
     1269                    (eq symbol *nx-global-function-name*))
     1270          (nx1-whine :undefined-function symbol))
    12851271        (make-acode (%nx1-default-operator) symbol))
    12861272      (make-acode (%nx1-operator call) (nx1-immediate '%function) (list nil (list sym))))))
     
    14991485     (nx1-form value))))
    15001486
    1501 (defnx1 nx1-funcall ((funcall)) (func &rest args &environment env)
    1502   (let ((name func))
    1503     (if (and (consp name)
    1504              (eq (%car name) 'function)
    1505              (consp (%cdr name))
    1506              (null (%cddr name))
    1507              (or
    1508               (if (symbolp (setq name (%cadr name)))
    1509                 (or (not (macro-function name *nx-lexical-environment*))
    1510                     (nx-error "Can't funcall macro function ~s ." name)))
    1511               (and (consp name)
    1512                    (or (when (eq (%car name) 'lambda)
    1513                          (nx-note-source-transformation func name)
    1514                          t)
    1515                        (setq name (nx-need-function-name name))))))
    1516       (nx1-form (cons name args))  ; This picks up call-next-method evil.
    1517       (let* ((result-type t))
    1518         (when (and (nx-form-constant-p func env)
    1519                    (or (typep (setq name (nx-form-constant-value func env)) 'symbol)
    1520                        (setq name (valid-function-name-p name))))
    1521           (setq result-type (nx1-call-result-type name args nil t)))
    1522         (let* ((form (nx1-call (nx1-form func) args nil t)))
    1523           (if (eq result-type t)
    1524             form
    1525             (make-acode (%nx1-operator typed-form) result-type form)))))))
     1487(defnx1 nx1-funcall ((funcall)) (&whole call func &rest args &environment env)
     1488  (let ((name (nx1-func-name func)))
     1489    (if (or (null name)
     1490            (and (symbolp name) (macro-function name env)))
     1491      (nx1-typed-call (nx1-form func) args nil)
     1492      (progn
     1493        (when (consp name) ;; lambda expression
     1494          (nx-note-source-transformation func name))
     1495        ;; This picks up call-next-method evil.
     1496        (nx1-form (let ((new-form (cons name args)))
     1497                    (nx-note-source-transformation call new-form)
     1498                    new-form))))))
    15261499
    15271500(defnx1 nx1-multiple-value-call multiple-value-call (value-form &rest args)
     
    15291502              (nx1-form value-form)
    15301503              (nx1-formlist args)))
    1531 
    1532 #|
    1533 (defun nx1-call-name (fn &aux (name (nx1-func-name fn)))
    1534   (if (and name (or (eq (%car fn) 'quote) (null (nx-lexical-finfo name))))
    1535     (make-acode (%nx1-operator immediate) name)
    1536     (or name (nx1-form fn))))
    1537 |#
    15381504
    15391505(defnx1 nx1-compiler-let compiler-let (bindings &body forms)
     
    20392005
    20402006(defnx1 nx1-x86-lap-function (x86-lap-function) (name bindings &body body)
    2041   (declare (ftype (function (t t t t)) %define-x86-lap-function))
     2007  (declare (ftype (function (t t t)) %define-x86-lap-function))
    20422008  (require "X86-LAP")
    20432009  (setf (afunc-lfun *nx-current-function*)
  • branches/working-0711/ccl/level-1/l1-clos-boot.lisp

    r12408 r12515  
    25332533)
    25342534
    2535 ;; Stub to prevent errors when the user doesn't define types
    2536 (defun type-intersect (type1 type2)
    2537   (cond ((and (null type1) (null type2))
    2538          nil)
    2539         ((equal type1 type2)
    2540          type1)
    2541         ((subtypep type1 type2)
    2542          type1)
    2543         ((subtypep type2 type1)
    2544          type2)
    2545         (t `(and ,type1 ,type2))
    2546         ;(t (error "type-intersect not implemented yet."))
    2547         ))
    2548 
    25492535(defun %add-direct-methods (method)
    25502536  (dolist (spec (%method-specializers method))
  • branches/working-0711/ccl/level-1/l1-typesys.lisp

    r12410 r12515  
    724724
    725725
     726(define-type-method (function :complex-intersection) (type1 type2)
     727  (declare (type function-ctype type2))
     728  (let ((function (specifier-type 'function)))
     729    (if (eq type1 function)
     730      type2
     731      (type-intersection2 type1 function))))
     732
     733
     734
    726735;;; ### Not very real, but good enough for redefining transforms according to
    727736;;; type:
     
    12221231;;; value (trying not to return a hairy type).
    12231232(defun type-approx-intersection2 (type1 type2)
     1233  (declare (type ctype type1 type2))
    12241234  (cond ((type-intersection2 type1 type2))
    12251235        ((hairy-ctype-p type1) type2)
     
    12661276(defun simplify-intersections (types)
    12671277  (when types
    1268     (multiple-value-bind (first rest)
    1269         (if (intersection-ctype-p (car types))
    1270             (values (car (intersection-ctype-types (car types)))
    1271                     (append (cdr (intersection-ctype-types (car types)))
     1278    (let ((first (if (typep (car types) 'ctype)
     1279                   (%car types)
     1280                   (specifier-type (%car types)))))
     1281      (multiple-value-bind (first rest)
     1282          (if (intersection-ctype-p first)
     1283            (values (car (intersection-ctype-types first))
     1284                    (append (cdr (intersection-ctype-types first))
    12721285                            (cdr types)))
    1273             (values (car types) (cdr types)))
    1274       (let ((rest (simplify-intersections rest)) u)
    1275         (dolist (r rest (cons first rest))
    1276           (when (setq u (type-intersection2 first r))
    1277             (return (simplify-intersections (nsubstitute u r rest)))))))))
     1286            (values first (cdr types)))
     1287        (let ((rest (simplify-intersections rest)) u)
     1288          (dolist (r rest (cons first rest))
     1289            (when (setq u (type-intersection2 first r))
     1290              (return (simplify-intersections (nsubstitute u r rest))))))))))
    12781291
    12791292(defun type-intersection2 (type1 type2)
     
    12951308        ((let ((function (specifier-type 'function)))
    12961309           (or (and (function-ctype-p type1)
    1297                     (not (or (function-ctype-p type2) (eq function type2)))
     1310                    (not (function-ctype-p type2))
     1311                    (neq function type2)
    12981312                    (csubtypep type2 function)
    12991313                    (not (csubtypep function type2)))
    13001314               (and (function-ctype-p type2)
    1301                     (not (or (function-ctype-p type1) (eq function type1)))
     1315                    (not (function-ctype-p type1))
     1316                    (neq function type1)
    13021317                    (csubtypep type1 function)
    13031318                    (not (csubtypep function type1)))))
     
    35443559           (> (count-if #'class-ctype-p (intersection-ctype-types type1)) 1))
    35453560      (values nil nil)
    3546       (invoke-complex-subtypep-arg1-method type1 class2 nil t)))
     3561      (if (function-ctype-p type1)
     3562        (csubtypep (specifier-type 'function) class2)
     3563        (invoke-complex-subtypep-arg1-method type1 class2 nil t))))
    35473564
    35483565(define-type-method (class :complex-subtypep-arg1) (type1 type2)
  • branches/working-0711/ccl/level-1/l1-utils.lisp

    r12410 r12515  
    571571  ;; Do not signal anything about unknown types though -- it should be ok to have forward
    572572  ;; references here, before anybody needs the info.
    573   (specifier-type ftype)
     573  (let* ((ctype (specifier-type ftype)))
     574    ;; If know enough to complain now, do so.
     575    (when (types-disjoint-p ctype (specifier-type 'function))
     576      (bad-proclaim-spec `(ftype ,ftype ,@names))))
    574577  (dolist (name names)
    575578    (setf (gethash (maybe-setf-function-name name) *nx-proclaimed-ftypes*) ftype)))
  • branches/working-0711/ccl/level-1/sysutils.lisp

    r12410 r12515  
    345345  (csubtypep (specifier-type type1 env) (specifier-type type2 env)))
    346346
     347(defun types-disjoint-p (type1 type2 &optional env)
     348  ;; Return true if types are guaranteed to be disjoint, nil if not disjoint or unknown.
     349  (let ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1 env)))
     350        (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2 env))))
     351    (eq *empty-type* (type-intersection ctype1 ctype2))))
    347352
    348353
  • branches/working-0711/ccl/lib/format.lisp

    r12410 r12515  
    22462246(defun nx-could-be-type (form type &optional transformed &aux (env *nx-lexical-environment*))
    22472247  (unless transformed (setq form (nx-transform form env)))
    2248   (if (constantp form)
    2249     (typep (eval-constant form) type env)
    2250     (multiple-value-bind (win-p sure-p) (subtypep (nx-form-type form env) `(not ,type) env)
    2251       (not (and win-p sure-p)))))
     2248  (if (nx-form-constant-p form env)
     2249    (typep (nx-form-constant-value form env) type env)
     2250    (not (types-disjoint-p (nx-form-type form env) type env))))
    22522251
    22532252(defun format-require-type (form type &optional description)
     
    23822381         ;; Would need to extend :undefined-function warnings to handle previously-undefined package.
    23832382         (when sym
    2384            (when (nth-value 1 (nx1-call-result-type sym (list* '*standard-output* arg colon atsign parms)))
     2383           (when (nx1-check-typed-call sym (list* '*standard-output* arg colon atsign parms))
    23852384             ;; Whined, just get out now.
    23862385             (throw 'format-error nil))))))
Note: See TracChangeset for help on using the changeset viewer.