Changeset 12515
- Timestamp:
- Aug 1, 2009, 3:50:08 PM (10 years ago)
- Location:
- branches/working-0711/ccl
- Files:
-
- 9 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0711/ccl/compiler/nx-basic.lisp
r12412 r12515 205 205 (%include "ccl:compiler;lambda-list.lisp") 206 206 207 207 #-BOOTSTRAPPED (unless (fboundp 'types-disjoint-p) 208 (fset 'types-disjoint-p (lambda (t1 t2 &optional env) t1 t2 env nil))) 208 209 209 210 … … 352 353 (assq sym *nx-proclaimed-types*)))) 353 354 (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)))))) 354 365 355 366 (defmacro define-declaration (decl-name lambda-list &body body &environment env) … … 598 609 (destructuring-bind (badguy goodguys) 599 610 (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)))) 601 613 (format stream 602 614 (ecase (compiler-warning-warning-type condition) 615 (:ftype-mismatch "the FTYPE declaration of ~s") 603 616 (:global-mismatch "the current global definition of ~s") 604 617 (:environment-mismatch "the definition of ~s visible in the current compilation unit.") … … 621 634 (:environment-mismatch . report-compile-time-argument-mismatch) 622 635 (:lexical-mismatch . report-compile-time-argument-mismatch) 636 (:ftype-mismatch . report-compile-time-argument-mismatch) 623 637 (:type . "Type declarations violated in ~S") 624 638 (:type-conflict . "Conflicting type declarations for ~S") -
branches/working-0711/ccl/compiler/nx.lisp
r12412 r12515 203 203 (:lexical-mismatch . invalid-arguments) 204 204 (:environment-mismatch . invalid-arguments) 205 (:ftype-mismatch . invalid-arguments) 205 206 (:ignore . style-warning) 206 207 (:result-ignored . style-warning) -
branches/working-0711/ccl/compiler/nx0.lisp
r12412 r12515 739 739 (rplacd (cdr decl) merged-type)))) 740 740 (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)))) 742 742 (when mdecls (setf (lexenv.mdecls env) (merge-decls mdecls (lexenv.mdecls env)))) 743 743 (setq *nx-inlined-self* (and (nx-self-calls-inlineable env) … … 816 816 (defnxdecl ftype (pending decl env &aux whined) 817 817 (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))))))))) 824 827 825 828 (defnxdecl settable (pending decl env) … … 1846 1849 (push warning (afunc-warnings p)))))) 1847 1850 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))) 1852 1854 (intersection (type-intersection ctype1 ctype2))) 1853 ( if(eq intersection *empty-type*)1855 (when (eq intersection *empty-type*) 1854 1856 (let ((type1 (if (typep type1 'ctype) 1855 1857 (type-specifier type1) … … 1860 1862 (nx1-whine :type-conflict form type1 type2))) 1861 1863 (type-specifier intersection))) 1862 1863 1864 1864 1865 1865 (defun nx-declared-notinline-p (sym env) … … 1900 1900 (nx1-typed-call (car args) (%cdr args))) 1901 1901 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) 1906 1916 form 1907 (make-acode (%nx1-operator typed-form) type form)))))1917 (make-acode (%nx1-operator typed-form) result-type form))))) 1908 1918 1909 1919 (defvar *format-arg-functions* '((format . 1) (format-to-string . 1) (error . 0) (warn . 0) … … 1918 1928 (compiler-bug . 0))) 1919 1929 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*)) 1956 1974 (setq sym (maybe-setf-function-name sym)) 1957 1975 (loop … … 1960 1978 (proclaimed-ftype sym)))) 1961 1979 (dolist (fdecl (lexenv.fdecls env)) 1962 (declare (list fdecl))1963 1980 (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)))) 1966 1983 (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 1967 2050 1968 2051 (defun innermost-lfun-bits-keyvect (def) … … 1996 2079 (if (lambda-expression-p lambda-form) 1997 2080 (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) 2019 2108 (declare (fixnum bits)) 2020 2109 (when (logbitp $lfbits-aok-bit bits) … … 2022 2111 (when (and (logbitp $lfbits-keys-bit bits) 2023 2112 (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)) 2025 2115 (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)))))))) 2038 2132 2039 2133 ;;; we can save some space by going through subprims to call "builtin" … … 2068 2162 (defun nx1-call (sym args &optional spread-p global-only inhibit-inline) 2069 2163 (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)))) 2070 2168 (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*)))) 2071 2169 (if (nx-self-call-p sym global-only) … … 2413 2511 (defun nx-form-type (form &optional (env *nx-lexical-environment*)) 2414 2512 (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)) 2416 2515 (if (and (consp form) ; Kinda bogus now, but require-type 2417 2516 (eq (%car form) 'require-type) ; should be special some day … … 2425 2524 (destructuring-bind (typespec val) (%cdr form) 2426 2525 (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))))) 2434 2527 (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)) 2436 2539 (let* ((op (gethash (%car form) *nx1-operators*))) 2437 2540 (or (and op (cdr (assq op *nx-operator-result-types*))) … … 2441 2544 (and (memq (car form) *logical-ops*) 2442 2545 (grovel-logical-form form env)) 2546 (nx-declared-result-type (%car form) env) 2443 2547 ;; Sort of the right idea, but this should be done 2444 2548 ;; in a more general way. … … 2453 2557 t)) 2454 2558 t)))) 2559 2455 2560 2456 2561 (defparameter *numeric-ops* '(+ - / * +-2 --2 *-2 /-2)) … … 2588 2693 (defun nx1-func-name (gizmo) 2589 2694 (and (consp gizmo) 2590 ( or (eq (%car gizmo) 'function) (eq (%car gizmo) 'quote))2695 (eq (%car gizmo) 'function) 2591 2696 (consp (%cdr gizmo)) 2592 2697 (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)))))) 2594 2701 2595 2702 ; distinguish between program errors & incidental ones. -
branches/working-0711/ccl/compiler/nx1.lisp
r12340 r12515 28 28 (let* ((ctype (handler-case (values-specifier-type (nx-target-type typespec) env) 29 29 (parse-unknown-type (c) 30 31 30 (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c)) 31 nil) 32 32 (program-error (c) 33 34 35 (if ( or (null ctype) (typep ctype 'values-ctype))33 (nx1-whine :invalid-type typespec c) 34 nil)))) 35 (if (null ctype) 36 36 '* 37 37 (if (typep ctype 'function-ctype) 38 38 'function 39 (nx-target-type (type-specifier ctype)))))))39 (nx-target-type (type-specifier (single-value-type ctype)))))))) 40 40 (let* ((typespec (typespec-for-the typespec)) 41 41 (*nx-form-type* typespec) 42 42 (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))47 43 (flet ((fold-the () 48 44 (do* () … … 63 59 (when (eq transformed last) 64 60 (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))) 65 70 (make-acode 66 71 (%nx1-operator typed-form) … … 1160 1165 1161 1166 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))) 1208 1191 1209 1192 … … 1281 1264 (setq symbol (cadr sym)) 1282 1265 (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)) 1285 1271 (make-acode (%nx1-default-operator) symbol)) 1286 1272 (make-acode (%nx1-operator call) (nx1-immediate '%function) (list nil (list sym)))))) … … 1499 1485 (nx1-form value)))) 1500 1486 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)))))) 1526 1499 1527 1500 (defnx1 nx1-multiple-value-call multiple-value-call (value-form &rest args) … … 1529 1502 (nx1-form value-form) 1530 1503 (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 |#1538 1504 1539 1505 (defnx1 nx1-compiler-let compiler-let (bindings &body forms) … … 2039 2005 2040 2006 (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)) 2042 2008 (require "X86-LAP") 2043 2009 (setf (afunc-lfun *nx-current-function*) -
branches/working-0711/ccl/level-1/l1-clos-boot.lisp
r12408 r12515 2533 2533 ) 2534 2534 2535 ;; Stub to prevent errors when the user doesn't define types2536 (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 2549 2535 (defun %add-direct-methods (method) 2550 2536 (dolist (spec (%method-specializers method)) -
branches/working-0711/ccl/level-1/l1-typesys.lisp
r12410 r12515 724 724 725 725 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 726 735 ;;; ### Not very real, but good enough for redefining transforms according to 727 736 ;;; type: … … 1222 1231 ;;; value (trying not to return a hairy type). 1223 1232 (defun type-approx-intersection2 (type1 type2) 1233 (declare (type ctype type1 type2)) 1224 1234 (cond ((type-intersection2 type1 type2)) 1225 1235 ((hairy-ctype-p type1) type2) … … 1266 1276 (defun simplify-intersections (types) 1267 1277 (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)) 1272 1285 (cdr types))) 1273 (values (car types)(cdr types)))1274 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)))))))))) 1278 1291 1279 1292 (defun type-intersection2 (type1 type2) … … 1295 1308 ((let ((function (specifier-type 'function))) 1296 1309 (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) 1298 1312 (csubtypep type2 function) 1299 1313 (not (csubtypep function type2))) 1300 1314 (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) 1302 1317 (csubtypep type1 function) 1303 1318 (not (csubtypep function type1))))) … … 3544 3559 (> (count-if #'class-ctype-p (intersection-ctype-types type1)) 1)) 3545 3560 (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)))) 3547 3564 3548 3565 (define-type-method (class :complex-subtypep-arg1) (type1 type2) -
branches/working-0711/ccl/level-1/l1-utils.lisp
r12410 r12515 571 571 ;; Do not signal anything about unknown types though -- it should be ok to have forward 572 572 ;; 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)))) 574 577 (dolist (name names) 575 578 (setf (gethash (maybe-setf-function-name name) *nx-proclaimed-ftypes*) ftype))) -
branches/working-0711/ccl/level-1/sysutils.lisp
r12410 r12515 345 345 (csubtypep (specifier-type type1 env) (specifier-type type2 env))) 346 346 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)))) 347 352 348 353 -
branches/working-0711/ccl/lib/format.lisp
r12410 r12515 2246 2246 (defun nx-could-be-type (form type &optional transformed &aux (env *nx-lexical-environment*)) 2247 2247 (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)))) 2252 2251 2253 2252 (defun format-require-type (form type &optional description) … … 2382 2381 ;; Would need to extend :undefined-function warnings to handle previously-undefined package. 2383 2382 (when sym 2384 (when (n th-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)) 2385 2384 ;; Whined, just get out now. 2386 2385 (throw 'format-error nil))))))
Note: See TracChangeset
for help on using the changeset viewer.