Changeset 12048


Ignore:
Timestamp:
May 13, 2009, 8:53:51 PM (10 years ago)
Author:
gz
Message:

r11876/r12026/r12045 from trunk

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

Legend:

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

    r11851 r12048  
    59725972                      (tail head))
    59735973                 (declare (dynamic-extent head)
    5974                           (cons (head tail)))
     5974                          (cons head tail))
    59755975                 (dolist (op operands)
    59765976                   (rplaca tail (parse-operand-form op))
  • branches/working-0711/ccl/compiler/backend.lisp

    r11836 r12048  
    348348  (declare (fixnum expected))
    349349  (let* ((class (hard-regspec-class regspec)))
    350     (declare (type (unsigned-byte 8 class)))
     350    (declare (type (unsigned-byte 8) class))
    351351    (if (logbitp class expected)
    352352      (values class (if (typep regspec 'lreg)
  • branches/working-0711/ccl/compiler/nx-basic.lisp

    r12020 r12048  
    4242
    4343(defvar *nx-current-code-note*)
     44
     45;; The problem with undefind type warnings is that there is no in-language way to shut
     46;; them up even when the reference is intentional.  (In case of undefined functions,
     47;; you can declare FTYPE and that will turn off any warnings without interfering with
     48;; the function being defined later).  For now just provide this as an out.
     49(defvar *compiler-warn-on-undefined-type-references* #+ccl-0711 t #-ccl-0711 t)
     50
     51
    4452
    4553;; In lieu of a slot in acode.  Don't reference this variable elsewhere because I'm
     
    575583    (:ignore . "Variable ~S not ignored.")
    576584    (:undefined-function . "Undefined function ~S")
     585    (:undefined-type . "Undefined type ~S")
    577586    (:unknown-declaration . "Unknown declaration ~S")
    578     (:unknown-type-declaration . "Unknown type ~S")
     587    (:invalid-type . report-invalid-type-compiler-warning)
    579588    (:unknown-declaration-variable . "~s declaration for unknown variable ~s")
    580589    (:macro-used-before-definition . "Macro function ~S was used before it was defined.")
     
    593602    (:unsure . "Nonspecific warning")))
    594603
     604(defun report-invalid-type-compiler-warning (condition stream)
     605  (destructuring-bind (type &optional why) (compiler-warning-args condition)
     606    (when (typep why 'invalid-type-specifier)
     607      (setq type (invalid-type-specifier-typespec why) why nil))
     608    (format stream "Invalid type specifier ~S~@[: ~A~]" type why)))
     609
    595610(defun report-compile-time-duplicate-definition (condition stream)
    596611  (destructuring-bind (name old-file new-file &optional from to) (compiler-warning-args condition)
     
    620635    (if (typep format-string 'string)
    621636      (apply #'format stream format-string (adjust-compiler-warning-args warning-type (compiler-warning-args condition)))
    622       (funcall format-string condition stream))
     637      (if (null format-string)
     638        (format stream "~A: ~S" warning-type (compiler-warning-args condition))
     639        (funcall format-string condition stream)))
    623640    ;(format stream ".")
    624641    (let ((nrefs (compiler-warning-nrefs condition)))
  • branches/working-0711/ccl/compiler/nx.lisp

    r11807 r12048  
    139139    lfun))
    140140
     141#-BOOTSTRAPPED (unless (find-class 'undefined-reference nil)
     142                 (deftype undefined-reference () 'undefined-function-reference)
     143                 (defclass undefined-type-reference (undefined-function-reference) ()))
     144
    141145(defun signal-or-defer-warnings (warnings env)
    142146  (let* ((defenv (definition-environment env))
     
    144148         (defer (and defenv (cdr (defenv.type defenv)) *outstanding-deferred-warnings*)))
    145149    (dolist (w warnings)
    146       (if (and defer (typep w 'undefined-function-reference))
     150      (if (and defer (typep w 'undefined-reference))
    147151        (push w (deferred-warnings.warnings defer))
    148152        (progn
     
    198202(defparameter *compiler-whining-conditions*
    199203  '((:undefined-function . undefined-function-reference)
     204    (:undefined-type . undefined-type-reference)
     205    (:invalid-type . invalid-type-warning)
    200206    (:global-mismatch . invalid-arguments-global)
    201207    (:lexical-mismatch . invalid-arguments)
  • branches/working-0711/ccl/compiler/nx0.lisp

    r11836 r12048  
    371371    (dolist (spec (%cdr decl))
    372372      (if (memq (setq s (car spec)) *nx-known-declarations*)
     373        ;;  Hmm, NOTSPECIAL and FUNCTION are in *nx-known-declarations* but have no standard handler.
    373374        (if (setq f (getf *nx-standard-declaration-handlers* s))
    374375          (funcall f pending spec env))
    375376        ; Any type name is now (ANSI CL) a valid declaration.
    376         ; We should probably do something to distinguish "type names" from "typo names",
    377         ; so that (declare (inliMe foo)) warns unless the compiler has some reason to
    378         ; believe that 'inliMe' (inlemon) has been DEFTYPEd.
    379         (dolist (var (%cdr spec))
    380           (if (symbolp var)
    381             (nx-new-vdecl pending var 'type s)))))))
     377        (if (symbolp s)
     378          (nx-process-type-decl pending spec s (%cdr spec) env)
     379          (nx-bad-decls spec))))))
    382380
    383381; Put all variable decls for the symbol VAR into effect in environment ENV.  Now.
     
    692690           (%cadr acode-expression)))))
    693691
     692(defun specifier-type-if-known (typespec &optional env &key whine)
     693  (handler-case (specifier-type typespec env)
     694    (parse-unknown-type (c)
     695      (when (and whine *compiler-warn-on-undefined-type-references*)
     696        (nx1-whine :undefined-type (parse-unknown-type-specifier c)))
     697      (values nil (parse-unknown-type-specifier c)))
     698    ;; catch any errors due to destructuring in type-expand
     699    (program-error (c)
     700      (when whine
     701        (nx1-whine :invalid-type typespec c))
     702      (values nil typespec))))
     703
     704#+debugging-version
     705(defun specifier-type-if-known (typespec &optional env &key whine)
     706  (handler-bind ((parse-unknown-type (lambda (c)
     707                                       (break "caught unknown-type ~s" c)
     708                                       (when (and whine *compiler-warn-on-undefined-type-references*)
     709                                         (nx1-whine :undefined-type (parse-unknown-type-specifier c)))
     710                                       (return-from specifier-type-if-known
     711                                         (values nil (parse-unknown-type-specifier c)))))
     712                 (program-error (lambda (c)
     713                                  (break "caught program-error ~s" c)
     714                                  (when whine
     715                                    (nx1-whine :invalid-type typespec c))
     716                                  (return-from specifier-type-if-known
     717                                    (values nil typespec)))))
     718    (specifier-type typespec env)))
     719
    694720(defun nx-check-vdecl-var-ref (decl)
    695721  (unless (eq (cadr decl) 'special)
     
    762788      (nx-bad-decls decl))))
    763789
     790(defnxdecl notspecial (pending decl env)
     791  (declare (ignore env))
     792  (dolist (s (%cdr decl))
     793    (if (symbolp s)
     794      (nx-new-vdecl pending s 'notspecial)
     795      (nx-bad-decls decl))))
     796
     797
    764798(defnxdecl dynamic-extent (pending decl env)
    765799  (declare (ignore env))
     
    789823
    790824(defnxdecl ftype (pending decl env)
    791   (declare (ignore env))
    792825  (destructuring-bind (type &rest fnames) (%cdr decl)
    793     (dolist (s fnames)
    794       (nx-new-fdecl pending s 'ftype type))))
     826    (if (not (every (lambda (f) (or (symbolp f) (setf-function-name-p f))) fnames))
     827      (nx-bad-decls decl)
     828      (let ((ctype (specifier-type-if-known type env :whine t)))
     829        (when ctype
     830          (dolist (s fnames)
     831            (nx-new-fdecl pending s 'ftype type)))))))
    795832
    796833(defnxdecl settable (pending decl env)
     
    807844      (nx-bad-decls decl))))
    808845
     846(defnxdecl function (pending decl env)
     847  (nx-process-type-decl pending decl (car decl) (cdr decl) env))
     848
    809849(defnxdecl type (pending decl env)
    810   (declare (ignore env))
    811   (labels ((kludge (type) ; 0 => known, 1 => unknown, 2=> illegal
    812              (cond ((type-specifier-p type)
    813                     0)
    814                    ((and (consp type)
    815                          (member (car type) '(and or))
    816                          (not (null (list-length type))))
    817                     (do ((result 0 (max result (kludge (car tail))))
    818                          (tail (cdr type) (cdr tail)))
    819                         ((null tail)
    820                          result)))
    821                    ((not (symbolp type))
    822                     ;;>>>> nx-bad-decls shouldn't signal a fatal error!!!!
    823                     ;;>>>> Most callers of nx-bad-decls should just ignore the
    824                     ;;>>>> losing decl element and proceed with the rest
    825                     ;;>>>>  (ie (declare (ignore foo (bar) baz)) should
    826                     ;;>>>>   have the effect of ignoring foo and baz as well
    827                     ;;>>>>   as WARNING about the mal-formed declaration.)
    828                     (nx-bad-decls decl)
    829                     2)
    830                    (t 1))))
    831     (let* ((spec (%cdr decl))
    832            (type (car spec)))
    833       (case (kludge type)
    834         ((0)
    835          (dolist (sym (cdr spec))
    836            (if (symbolp sym)
    837              (nx-new-vdecl pending sym 'type type)
    838              (nx-bad-decls decl))))
    839         ((1)
    840          (dolist (sym (cdr spec))
    841            (unless (symbolp sym)
    842              (nx-bad-decls decl))))
    843         ((2)
    844          (nx-bad-decls decl))))))
    845 
    846 
     850  (nx-process-type-decl pending decl (cadr decl) (cddr decl) env))
     851
     852(defun nx-process-type-decl (pending decl type vars env)
     853  (if (not (every #'symbolp vars))
     854    (nx-bad-decls decl)
     855    (let ((ctype (specifier-type-if-known type env :whine t)))
     856      (when ctype
     857        (dolist (sym vars)
     858          (nx-new-vdecl pending sym 'type ctype))))))
    847859
    848860(defnxdecl global-function-name (pending decl env)
  • branches/working-0711/ccl/compiler/nx1.lisp

    r11850 r12048  
    2929  ;; in type declarations, but aren't legal args to TYPEP;
    3030  ;; treat them as the simple FUNCTION type.
    31   (let* ((ctype (values-specifier-type typespec)))
    32     (if (typep ctype 'values-ctype)       
     31  (let* ((ctype (handler-case (values-specifier-type typespec)
     32                  (parse-unknown-type (c)
     33                    (when *compiler-warn-on-undefined-type-references*
     34                      (nx1-whine :undefined-type (parse-unknown-type-specifier c))
     35                      nil))
     36                  (program-error (c)
     37                    (nx1-whine :invalid-type typespec c)
     38                    nil))))
     39    (if (or (null ctype) (typep ctype 'values-ctype))
    3340      (setq typespec '*)
    3441      (if (typep ctype 'function-ctype)
  • branches/working-0711/ccl/compiler/optimizers.lisp

    r11834 r12048  
    638638      `(progn ,@body))))
    639639
    640 (defun specifier-type-if-known (typespec &optional env)
    641   (handler-case (specifier-type typespec env)
    642     (parse-unknown-type (c) (values nil (parse-unknown-type-specifier c)))))
    643 
    644 #+debugging-version
    645 (defun specifier-type-if-known (typespec &optional env)
    646   (handler-bind ((parse-unknown-type (lambda (c)
    647                                        (break "caught unknown-type ~s" c)
    648                                        (return-from specifier-type-if-known
    649                                          (values nil (parse-unknown-type-specifier c))))))
    650     (specifier-type typespec env)))
    651 
    652 
    653640(defun target-element-type-type-keyword (typespec &optional env)
    654   (let* ((ctype (specifier-type-if-known `(array ,typespec) env)))
    655     (if (null ctype)
    656       (progn
    657         (nx1-whine :unknown-type-declaration typespec)
    658         nil)
     641  (let ((ctype (specifier-type-if-known `(array ,typespec) env)))
     642    (when ctype
    659643      (funcall (arch::target-array-type-name-from-ctype-function
    660                 (backend-target-arch *target-backend*))
    661                ctype))))
     644                (backend-target-arch *target-backend*))
     645               ctype))))
    662646
    663647(defun infer-array-type (dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)
     
    696680                         '*)
    697681                       t))
    698            (element-type (or (specifier-type-if-known typespec env)
    699                              (make-unknown-ctype :specifier typespec))))
    700       (setf (array-ctype-element-type ctype) element-type)
    701       (if (typep element-type 'unknown-ctype)
    702         (setf (array-ctype-element-type ctype) *wild-type*))
     682           (element-type (specifier-type-if-known typespec env :whine t)))
     683      (setf (array-ctype-element-type ctype) (or element-type *wild-type*))
    703684      (specialize-array-type ctype))
    704685    (type-specifier ctype)))
     
    726707             (expansion
    727708              (cond ((and initial-element-p initial-contents-p)
    728                      (nx1-whine 'illegal-arguments call)
     709                     (signal-program-error  "Incompatible arguments :INITIAL-ELEMENT and :INITIAL-CONTENTS in ~s" call)
    729710                     call)
    730711                    (displaced-to-p
     
    957938                  (and (quoted-form-p type)
    958939                       (setq type (%cadr type))))
    959               (setq ctype (specifier-type-if-known type env)))
     940              (setq ctype (specifier-type-if-known type env :whine t)))
    960941         (cond ((nx-form-typep arg type env) arg)
    961942               ((and (nx-trust-declarations env) ;; if don't trust declarations, don't bother.
     
    15241505
    15251506
    1526 
    15271507(defun optimize-typep (thing type env)
    15281508  ;; returns a new form, or nil if it can't optimize
    1529   (let* ((ctype (specifier-type-if-known type env)))
     1509  (let ((ctype (specifier-type-if-known type env :whine t)))
    15301510    (when ctype
    15311511      (let* ((type (type-specifier ctype))
     
    22842264        (t call)))
    22852265
    2286 (define-compiler-macro coerce (&whole call thing type)
    2287   (if (quoted-form-p type)
    2288     (setq type (cadr type)))
    2289   (if (ignore-errors (subtypep type 'single-float))
    2290     `(float ,thing 0.0f0)
    2291     (if (ignore-errors (subtypep type 'double-float))
    2292       `(float ,thing 0.0d0)
    2293       call)))
     2266(define-compiler-macro coerce (&whole call &environment env thing type)
     2267  (cond ((quoted-form-p type)
     2268         (setq type (cadr type))
     2269         (let ((ctype (specifier-type-if-known type env :whine t)))
     2270           (if ctype
     2271             (if (csubtypep ctype (specifier-type 'single-float))
     2272                 `(float ,thing 0.0f0)
     2273                 (if (csubtypep ctype (specifier-type 'double-float))
     2274                     `(float ,thing 0.0d0)
     2275                     (let ((simple nil)
     2276                           (extra nil))
     2277                       (if (and (typep ctype 'array-ctype)
     2278                                (equal (array-ctype-dimensions ctype) '(*)))
     2279                           (if (eq (array-ctype-specialized-element-type ctype)
     2280                                   (specifier-type 'character))
     2281                               (setq simple '%coerce-to-string)
     2282                               (if (and (eq *host-backend* *target-backend*)
     2283                                        (array-ctype-typecode ctype))
     2284                                   (setq simple '%coerce-to-vector
     2285                                         extra (list (array-ctype-typecode ctype)))))
     2286                           (if (eq ctype (specifier-type 'list))
     2287                               (setq simple '%coerce-to-list)))
     2288                       (if simple
     2289                           (let* ((temp (gensym)))
     2290                             `(let* ((,temp ,thing))
     2291                                (if (typep ,temp ',(type-specifier ctype))
     2292                                    ,temp
     2293                                    (,simple ,temp ,@extra))))
     2294                           call))))
     2295             call)))
     2296        (t call)))
    22942297
    22952298(define-compiler-macro equal (&whole call x y &environment env)
  • branches/working-0711/ccl/level-0/l0-bignum64.lisp

    r11164 r12048  
    223223        (dotimes (i len-b)
    224224          (let* ((sum (+
    225                        (the fixnum (+ (the digit-type (bignum-ref a i))
    226                                       (the digit-type (bignum-ref b i))))
     225                       (the fixnum (+ (the bignum-element-type (bignum-ref a i))
     226                                      (the bignum-element-type (bignum-ref b i))))
    227227                       carry)))
    228228            (declare (fixnum sum))
     
    233233          (setf (bignum-ref res len-a)
    234234                (+ (the fixnum carry)
    235                    (the fixnum (+ (the digit-type (%bignum-sign a))
     235                   (the fixnum (+ (the bignum-element-type (%bignum-sign a))
    236236                                  sign-b)))))
    237237        (%normalize-bignum-macro res))))
     
    248248    (declare (bignum-index len-bignum)
    249249             (bignum-type res)
    250              (digit-type low high))
    251     (let* ((sum0 (+ (the digit-type (bignum-ref bignum 0)) low))
    252            (sum1 (+ (the fixnum (+ (the digit-type (bignum-ref bignum 1))
     250             (bignum-element-type low high))
     251    (let* ((sum0 (+ (the bignum-element-type (bignum-ref bignum 0)) low))
     252           (sum1 (+ (the fixnum (+ (the bignum-element-type (bignum-ref bignum 1))
    253253                                   high))
    254254                    (the fixnum (logand 1 (ash sum0 -32)))))
    255255           (carry (logand 1 (ash sum1 -32))))
    256       (declare (fixnum sum0 sum1) (digit-type carry))
     256      (declare (fixnum sum0 sum1) (bignum-element-type carry))
    257257      (setf (bignum-ref res 0) sum0
    258258            (bignum-ref res 1) sum1)
     
    261261        (setf (bignum-ref res 2)
    262262              (+ (the fixnum carry)
    263                  (the fixnum (+ (the digit-type (%bignum-sign bignum))
     263                 (the fixnum (+ (the bignum-element-type (%bignum-sign bignum))
    264264                                (the fixnum (ash fixnum (- (- target::nbits-in-word target::fixnumshift)))))))))
    265265      (%normalize-bignum-macro res))))
     
    273273(defun finish-bignum-add (result carry a sign-b start end)
    274274  (declare (type bignum-index start end)
    275            (digit-type sign-b carry)
     275           (bignum-element-type sign-b carry)
    276276           (optimize (speed 3) (safety 0)))
    277277  (do* ((i start (1+ i))
     
    286286                                          sign-b))
    287287                           carry))))
    288     (declare (fixnum i) (digit-type sign-b))
     288    (declare (fixnum i) (bignum-element-type sign-b))
    289289    (let* ((sum (the fixnum (+ (the fixnum (+ (bignum-ref a i)
    290290                                              sign-b))
     
    316316           (sign-a (%bignum-sign a))
    317317           (sign-b (%bignum-sign b)))
    318       (declare (digit-type borrow sign-a sign-b))
     318      (declare (bignum-element-type borrow sign-a sign-b))
    319319      (dotimes (i (the bignum-index len-res))
    320320        (multiple-value-bind (result-digit borrow-out)
  • branches/working-0711/ccl/level-0/l0-hash.lisp

    r11069 r12048  
    179179          (let* ((pname (%svref vector target::symbol.pname-cell))
    180180                 (hash (mixup-hash-code (%pname-hash pname (uvsize pname)))))
    181             (declare (type (simple-string pname)))
     181            (declare (type simple-string pname))
    182182            (if cell
    183183              (setf (car cell) hash)
  • branches/working-0711/ccl/level-1/l1-aprims.lisp

    r11821 r12048  
    34983498  (let* ((code (char-code c))
    34993499         (bits *alpha-char-bits*))
    3500     (declare (type (mod #x110000 code))
     3500    (declare (type (mod #x110000) code)
    35013501             (simple-bit-vector bits))
    35023502    (and (< code (length bits))
  • branches/working-0711/ccl/level-1/l1-clos-boot.lisp

    r11836 r12048  
    556556
    557557
    558 (defstatic *type-system-initialized* nil)
    559 
    560558(eval-when (eval compile)
    561559  (require 'defstruct-macros))
     
    13561354
    13571355(defun %compile-time-defclass (name environment)
     1356  (note-type-info name 'class environment)
    13581357  (unless (find-class name nil environment)
    13591358    (let ((defenv (definition-environment environment)))
  • branches/working-0711/ccl/level-1/l1-clos.lisp

    r12015 r12048  
    12021202
    12031203;;; Fake method-combination, redefined in lib;method-combination.
    1204 (defclass method-combination (metaobject)
    1205   ((name :initarg :name)))
     1204(unless *type-system-initialized*
     1205 (defclass method-combination (metaobject)
     1206   ((name :initarg :name))))
    12061207
    12071208
  • branches/working-0711/ccl/level-1/l1-error-system.lisp

    r12032 r12048  
    7575  ((warning-type :initform :unsure)
    7676   (args :initform nil)))
    77 (define-condition undefined-function-reference (style-warning) ())
     77(define-condition undefined-reference (style-warning) ())
     78(define-condition undefined-type-reference (undefined-reference) ())
     79(define-condition undefined-function-reference (undefined-reference) ())
    7880(define-condition macro-used-before-definition (compiler-warning) ())
     81(define-condition invalid-type-warning (style-warning) ())
    7982(define-condition invalid-arguments (style-warning) ())
    8083(define-condition invalid-arguments-global (style-warning) ())
  • branches/working-0711/ccl/level-1/l1-init.lisp

    r11812 r12048  
    165165  "symbols which are magical in a lambda list")
    166166
     167(defstatic *type-system-initialized* nil)
    167168
    168169(defparameter %toplevel-catch% ':toplevel)
     
    239240(defvar ccl::*kernel-restarts* nil)
    240241(defvar *condition-restarts* nil "explicit mapping between c & r")
    241 (declaim (type list %handlers% %restarts% ccl::*kernel-restarts* *condition-restarts*))
     242(declaim (list %handlers% %restarts% ccl::*kernel-restarts* *condition-restarts*))
    242243
    243244
  • branches/working-0711/ccl/level-1/l1-readloop.lisp

    r11786 r12048  
    415415    (defmacro (setq lambda '(macro) lfbits nil)) ;; some code assumes lfbits=nil
    416416    (defgeneric (setq lambda (list :methods)))
    417     (defmethod (setq lambda (list :methods (cons qualifiers specializers)))))
     417    (defmethod (setq lambda (list :methods (cons qualifiers specializers))))
     418    (deftype (setq lambda '(type) lfbits (cons nil *loading-file-source-file*))))
    418419  (vector lfbits keyvect *loading-file-source-file* lambda))
    419420
    420421(defun def-info.lfbits (def-info)
    421   (and def-info (svref def-info 0)))
     422  (and def-info
     423       (let ((lfbits (svref def-info 0)))
     424         (if (consp lfbits) (%car lfbits) lfbits))))
    422425
    423426(defun def-info.keyvect (def-info)
     
    428431
    429432(defun def-info.lambda (def-info)
    430   (let ((data (and def-info (svref def-info 3))))
    431     (and (eq (car data) 'lambda) data)))
     433  (and def-info
     434       (let ((data (svref def-info 3)))
     435         (and (eq (car data) 'lambda) data))))
    432436
    433437(defun def-info.methods (def-info)
    434   (let ((data (and def-info (svref def-info 3))))
    435     (and (eq (car data) :methods) (%cdr data))))
     438  (and def-info
     439       (let ((data (svref def-info 3)))
     440         (and (eq (car data) :methods) (%cdr data)))))
    436441
    437442(defun def-info-with-new-methods (def-info new-methods)
    438   (unless (eq (def-info.type def-info) 'defgeneric) (error "Bug: not method info: ~s" def-info))
    439443  (if (eq new-methods (def-info.methods def-info))
    440444    def-info
     
    447451    (eq (car data) 'macro)))
    448452
    449 (defun def-info.type (def-info)
    450   (if (null def-info) nil  ;; means FTYPE decl or lap function
     453(defun def-info.function-p (def-info)
     454  (not (and def-info (eq (car (svref def-info 3)) 'type))))
     455
     456(defun def-info.function-type (def-info)
     457  (if (null def-info)
     458    nil ;; ftype only, for the purposes here, is same as nothing.
    451459    (let ((data (svref def-info 3)))
    452460      (ecase (car data)
    453         ((nil lambda) 'defun)
    454         (:methods 'defgeneric)
    455         (macro 'defmacro)))))
     461        ((nil lambda) 'defun)
     462        (:methods 'defgeneric)
     463        (macro 'defmacro)
     464        (ftype nil)
     465        (type nil)))))
     466
     467(defun def-info.deftype (def-info)
     468  (and def-info
     469       (let ((bits (svref def-info 0)))
     470         ;; bits or (bits . type-source-file)
     471         (and (consp bits) bits))))
     472
     473(defun def-info.deftype-type (def-info)
     474  ;; 'class (for defclass/defstruct) or 'macro (for deftype et. al.)
     475  (and def-info
     476       (consp (svref def-info 0))
     477       (svref def-info 1)))
    456478
    457479(defparameter *one-arg-defun-def-info* (%cons-def-info 'defun (encode-lambda-list '(x))))
     
    459481(defvar *compiler-warn-on-duplicate-definitions* t)
    460482
    461 (defun combine-function-infos (name old-info new-info)
    462   (let ((old-type (def-info.type old-info))
    463         (new-type (def-info.type new-info)))
     483(defun combine-deftype-infos (name def-info old-deftype new-deftype)
     484  (when (or new-deftype old-deftype)
     485    (when (and old-deftype new-deftype *compiler-warn-on-duplicate-definitions*)
     486      (nx1-whine :duplicate-definition
     487                 `(type ,name)
     488                 (cdr old-deftype)
     489                 (cdr new-deftype)))
     490    (let ((target (if new-deftype
     491                      (or (cdr new-deftype) (cdr old-deftype))
     492                      (cdr old-deftype)))
     493          (target-deftype (def-info.deftype def-info)))
     494      (unless (and target-deftype (eq (cdr target-deftype) target))
     495        (setq def-info (copy-seq (or def-info '#(nil nil nil (ftype)))))
     496        (setf (svref def-info 0) (cons (def-info.lfbits def-info) target)))))
     497  def-info)
     498
     499#+debug
     500(defun describe-def-info (def-info)
     501  (list :lfbits (def-info.lfbits def-info)
     502        :keyvect (def-info.keyvect def-info)
     503        :macro-p (def-info.macro-p def-info)
     504        :function-p (def-info.function-p def-info)
     505        :lambda (and (def-info.function-p def-info) (def-info.lambda def-info))
     506        :methods (and (def-info.function-p def-info) (def-info.methods def-info))
     507        :function-type (def-info.function-type def-info)
     508        :deftype (def-info.deftype def-info)
     509        :deftype-type (def-info.deftype-type def-info)))
     510
     511(defun combine-definition-infos (name old-info new-info)
     512  (let ((old-type (def-info.function-type old-info))  ;; defmacro
     513        (old-deftype (def-info.deftype old-info))      ;; nil
     514        (new-type (def-info.function-type new-info))  ;; nil
     515        (new-deftype (def-info.deftype new-info)))   ;; (nil . file)
    464516    (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric))
    465517           ;; TODO: Check compatibility of lfbits...
     
    475527                                     (def-info.file new-info)))
    476528                        (push new-method old-methods)))
    477              (def-info-with-new-methods old-info old-methods)))
    478           ((or (eq (or old-type 'defun) (or new-type 'defun))
    479                (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
     529             (setq new-info (def-info-with-new-methods old-info old-methods))))
     530          ((or (eq (or old-type 'defun) (or new-type 'defun))
     531               (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
    480532           (when (and old-type new-type *compiler-warn-on-duplicate-definitions*)
    481533             (nx1-whine :duplicate-definition name (def-info.file old-info) (def-info.file new-info)))
    482            (or new-info old-info))
     534           (unless new-info (setq new-info old-info)))
    483535          (t
    484            (when *compiler-warn-on-duplicate-definitions*
     536           (when (and (def-info.function-p old-info) (def-info.function-p new-info)
     537                      *compiler-warn-on-duplicate-definitions*)
    485538             (apply #'nx1-whine :duplicate-definition
    486539                    name
     
    491544                          ((eq old-type 'defgeneric) '("generic function" "function"))
    492545                          (t '("function" "generic function")))))
    493            new-info))))
    494 
    495 (defun record-function-info (name info env)
     546           (unless new-type (setq new-info old-info))))
     547    (combine-deftype-infos name new-info old-deftype new-deftype)))
     548
     549(defun record-definition-info (name info env)
    496550  (let* ((definition-env (definition-environment env)))
    497551    (if definition-env
     
    499553             (already (if (listp defs) (assq name defs) (gethash name defs))))
    500554        (if already
    501           (setf (%cdr already) (combine-function-infos name (%cdr already) info))
     555          (setf (%cdr already) (combine-definition-infos name (%cdr already) info))
    502556          (let ((outer (loop for defer = (cdr (defenv.type definition-env))
    503557                               then (deferred-warnings.parent defer)
     
    505559                             thereis (gethash name (deferred-warnings.defs defer)))))
    506560            (when outer
    507               (setq info (combine-function-infos name (%cdr outer) info)))
     561              (setq info (combine-definition-infos name (%cdr outer) info)))
    508562            (let ((new (cons name info)))
    509563              (if (listp defs)
     
    512566        info))))
    513567
     568(defun record-function-info (name info env)
     569  (record-definition-info name info env))
    514570
    515571;;; This is different from AUGMENT-ENVIRONMENT.
     
    524580  name)
    525581
     582(defun note-type-info (name kind env)
     583  (record-definition-info name (%cons-def-info 'deftype nil kind) env))
     584
     585
    526586; And this is different from FUNCTION-INFORMATION.
    527587(defun retrieve-environment-function-info (name env)
    528588 (let ((defenv (definition-environment env)))
    529589   (when defenv
    530      (let ((defs (defenv.defined defenv))
    531            (sym (maybe-setf-function-name name)))
    532        (if (listp defs) (assq sym defs) (gethash sym defs))))))
     590     (let* ((defs (defenv.defined defenv))
     591            (sym (maybe-setf-function-name name))
     592            (info (if (listp defs) (assq sym defs) (gethash sym defs))))
     593       (and info (def-info.function-p (cdr info)) info)))))
    533594
    534595(defun maybe-setf-function-name (name)
  • branches/working-0711/ccl/level-1/l1-streams.lisp

    r11653 r12048  
    19241924(defun %ioblock-write-u8-encoded-simple-string (ioblock string start-char num-chars)
    19251925  (declare (fixnum start-char num-chars)
    1926            (simple-base-strng string)
     1926           (simple-base-string string)
    19271927           (optimize (speed 3) (safety 0)))
    19281928  (do* ((i 0 (1+ i))
     
    19751975(defun %ioblock-write-u16-encoded-simple-string (ioblock string start-char num-chars)
    19761976  (declare (fixnum start-char num-chars)
    1977            (simple-base-strng string)
     1977           (simple-base-string string)
    19781978           (optimize (speed 3) (safety 0)))
    19791979  (when (ioblock-pending-byte-order-mark ioblock)
     
    20242024(defun %ioblock-write-swapped-u16-encoded-simple-string (ioblock string start-char num-chars)
    20252025  (declare (fixnum start-char num-chars)
    2026            (simple-base-strng string)
     2026           (simple-base-string string)
    20272027           (optimize (speed 3) (safety 0)))
    20282028  (do* ((i 0 (1+ i))
     
    20572057    (incf (ioblock-charpos ioblock)))
    20582058  (let* ((code (char-code char)))
    2059     (declare (type (mod #x110000 code)))
     2059    (declare (type (mod #x110000) code))
    20602060    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
    20612061      (%ioblock-write-u32-code-unit ioblock code)
     
    20772077(defun %ioblock-write-u32-encoded-simple-string (ioblock string start-char num-chars)
    20782078  (declare (fixnum start-char num-chars)
    2079            (simple-base-strng string)
     2079           (simple-base-string string)
    20802080           (optimize (speed 3) (safety 0)))
    20812081  (when (ioblock-pending-byte-order-mark ioblock)
     
    21072107    (incf (ioblock-charpos ioblock)))
    21082108  (let* ((code (char-code char)))
    2109     (declare (type (mod #x110000 code)))
     2109    (declare (type (mod #x110000) code))
    21102110    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
    21112111      (%ioblock-write-swapped-u32-code-unit ioblock code)
     
    21272127(defun %ioblock-write-swapped-u32-encoded-simple-string (ioblock string start-char num-chars)
    21282128  (declare (fixnum start-char num-chars)
    2129            (simple-base-strng string)
     2129           (simple-base-string string)
    21302130           (optimize (speed 3) (safety 0)))
    21312131  (do* ((i 0 (1+ i))
  • branches/working-0711/ccl/level-1/l1-typesys.lisp

    r12030 r12048  
    114114                  (let ((c (find-class name nil)))
    115115                    (and c (eq (class-name c) name)))))
    116          (error "Cannot redefine type ~S" name))
     116         (error "Cannot redefine type ~S because ~:[it is the name of a class~;it is a built-in type~]" name (built-in-type-p name)))
     117        ((memq name *nx-known-declarations*)
     118         (check-declaration-redefinition name 'deftype))
    117119        (t (setf (gethash name %deftype-expanders%) fn)
    118120           (record-source-file name 'type)))
     
    146148  (multiple-value-bind (lambda doc)
    147149      (parse-macro-internal name arglist body env '*)
    148       `(eval-when (:compile-toplevel :load-toplevel :execute)
    149          (,definer ',name
    150                    (nfunction ,name ,lambda)
    151                    ,doc))))
     150    `(progn
     151       (eval-when (:compile-toplevel)
     152         (note-type-info ',name 'macro ,env))
     153       (eval-when (:compile-toplevel :load-toplevel :execute)
     154         (,definer ',name
     155             (nfunction ,name ,lambda)
     156           ,doc)))))
    152157
    153158(defmacro deftype (name arglist &body body &environment env)
     
    904909;;;
    905910(defun values-type-types (type &optional (default-type *empty-type*))
    906   (declare (type values-type type))
     911  (declare (type values-ctype type))
    907912  (values (append (args-ctype-required type)
    908913                  (args-ctype-optional type))
     
    15411546  (handler-case
    15421547      (type-specifier (specifier-type spec env))
    1543     (invalid-type-specifier () spec)
     1548    (program-error () spec)
    15441549    (parse-unknown-type () spec)))
    15451550
     
    24702475  (coerce-bound bound type #'coerce))
    24712476
     2477#|
    24722478(def-type-translator real (&optional (low '*) (high '*))
    24732479  (specifier-type `(or (float ,(coerced-real-bound  low 'float)
     
    24822488        (double-float ,(coerced-float-bound  low 'double-float)
    24832489                      ,(coerced-float-bound high 'double-float)))))
     2490|#
    24842491
    24852492(def-bounded-type float float nil)
     
    25872594;;;
    25882595(define-type-method (number :simple-intersection) (type1 type2)
    2589   (declare (type numeric-type type1 type2))
     2596  (declare (type numeric-ctype type1 type2))
    25902597  (if (numeric-types-intersect type1 type2)
    25912598    (let* ((class1 (numeric-ctype-class type1))
     
    33633370           
    33643371(define-type-method (cons :simple-intersection) (type1 type2)
    3365   (declare (type cons-type type1 type2))
     3372  (declare (type cons-ctype type1 type2))
    33663373  (let ((car-int2 (type-intersection2 (cons-ctype-car-ctype type1)
    33673374                                      (cons-ctype-car-ctype type2)))
     
    43424349                    (unless (eq ctype *universal-type*)
    43434350                      (generate-predicate-for-ctype ctype)))
    4344                 (invalid-type-specifier ()
     4351                (program-error ()
    43454352                  (warn "Invalid type specifier ~s in slot definition for ~s in class ~s." type (slot-definition-name spec) (slot-definition-class spec))
    43464353                  (lambda (v)
  • branches/working-0711/ccl/level-1/l1-unicode.lisp

    r11655 r12048  
    38293829             (nchars 0 (1+ nchars)))
    38303830            ((> j end) (values nchars (- i origin)))
    3831          (declare (fixnum (i j end nchars)))
     3831         (declare (fixnum i j end nchars))
    38323832         (let* ((code (%get-unsigned-word pointer i)))
    38333833           (declare (type (unsigned-byte 16) code))
  • branches/working-0711/ccl/level-1/l1-utils.lisp

    r11267 r12048  
    536536    ;(function (proclaim-ftype (cons 'function (cddr spec)) (cadr spec)))
    537537    (t (unless (memq (%car spec) *nx-known-declarations*) ;not really right...
    538          ;; Any type name is now (ANSI CL) a valid declaration.
    539          (if (and (symbolp (%car spec))
    540                   (type-specifier-p (%car spec)))
     538         ;; Any type name is now (ANSI CL) a valid declaration.  Any symbol could become a type.
     539         (if (symbolp (%car spec))
    541540           (apply #'proclaim-type spec)
    542541           (warn "Unknown declaration specifier(s) in ~S" spec))))))
     
    547546    (if (symbolp var)
    548547      (let ((spec (assq var *nx-proclaimed-types*)))
     548        ;; Check the type.  This will signal program-error's in case of invalid types, let it.
     549        (when *type-system-initialized*
     550          (handler-case (specifier-type type)
     551            (parse-unknown-type (c)
     552              (warn "Undefined type ~s declaration for ~S" (parse-unknown-type-specifier c) var))))
    549553        (if spec
    550554          (rplacd spec type)
     
    593597  (declare (dynamic-extent syms))
    594598  (dolist (sym syms)
     599    (when (type-specifier-p sym)
     600      (error "Cannot define declaration ~s because it is the name of a type" sym))
    595601    (setq *nx-known-declarations*
    596602          (adjoin sym *nx-known-declarations* :test 'eq))))
     603
     604(defun check-declaration-redefinition (name why)
     605  (when (memq name *nx-known-declarations*)
     606    (cerror "Undeclare the declaration ~*~s"
     607            "Cannot ~a ~s because ~:*~s has been declared as a declaration name" why name)
     608    (setq *nx-known-declarations* (remove name *nx-known-declarations*))))
    597609
    598610(defun proclaim-ignore (t-or-nil &rest syms)
  • branches/working-0711/ccl/level-1/sysutils.lisp

    r11598 r12048  
    555555
    556556
     557;; Should be a generic function but compiler-warning class not defined yet.
     558(defun verify-deferred-warning (w)
     559  (etypecase w
     560    (undefined-type-reference (verify-deferred-type-warning w))
     561    (undefined-function-reference (verify-deferred-function-warning w))
     562    (compiler-warning nil)))
     563
     564(defun verify-deferred-type-warning (w)
     565  (let* ((args (compiler-warning-args w))
     566         (typespec (car args))
     567         (defs (deferred-warnings.defs *outstanding-deferred-warnings*)))
     568    (handler-bind ((parse-unknown-type
     569                    (lambda (c)
     570                      (let* ((type (parse-unknown-type-specifier c))
     571                             (spec (if (consp type) (car type) type))
     572                             (cell (and (symbolp spec) (gethash spec defs))))
     573                        (unless (and cell (def-info.deftype (cdr cell)))
     574                          (when (and args (neq type typespec))
     575                            (setf (car args) type))
     576                          (return-from verify-deferred-type-warning w))
     577                        ;; Else got defined.  TODO: Should check syntax, but don't have enuff info.
     578                        ;; TODO: should note if got defined as a deftype (rather than class or struct) and
     579                        ;; warn about forward reference, akin to the macro warning?  Might be missing out on
     580                        ;; some intended optimizations.
     581                        )))
     582                   (program-error ;; got defined, but turns out it's being used wrong
     583                    (lambda (c)
     584                      (let ((w2 (make-condition 'invalid-type-warning
     585                                  :file-name (compiler-warning-file-name w)
     586                                  :function-name (compiler-warning-function-name w)
     587                                  :source-note (compiler-warning-source-note w)
     588                                  :warning-type :invalid-type
     589                                  :args (list typespec c))))
     590                        (setf (compiler-warning-stream-position w2)
     591                              (compiler-warning-stream-position w))
     592                        (return-from verify-deferred-type-warning w2)))))
     593      (values-specifier-type typespec)
     594      nil)))
     595
     596
     597(defun verify-deferred-function-warning (w)
     598  (let* ((args (compiler-warning-args w))
     599         (wfname (car args))
     600         (defs (deferred-warnings.defs *outstanding-deferred-warnings*))
     601         (def (or (let ((cell (gethash wfname defs)))
     602                   (and cell (def-info.function-p (cdr cell)) cell))
     603                 (let* ((global (fboundp wfname)))
     604                   (and (typep global 'function) global)))))
     605    (cond ((null def) w)
     606          ((or (typep def 'function)
     607               (and (consp def)
     608                    (def-info.lfbits (cdr def))))
     609           ;; Check args in call to forward-referenced function.
     610           (when (cdr args)
     611             (destructuring-bind (arglist spread-p) (cdr args)
     612               (multiple-value-bind (deftype reason)
     613                   (nx1-check-call-args def arglist spread-p)
     614                 (when deftype
     615                   (let* ((w2 (make-condition
     616                               'invalid-arguments
     617                               :file-name (compiler-warning-file-name w)
     618                               :function-name (compiler-warning-function-name w)
     619                               :source-note (compiler-warning-source-note w)
     620                               :warning-type deftype
     621                               :args (list (car args) reason arglist spread-p))))
     622                     (setf (compiler-warning-stream-position w2)
     623                           (compiler-warning-stream-position w))
     624                     w2))))))
     625          ((def-info.macro-p (cdr def))
     626           (let* ((w2 (make-condition
     627                       'macro-used-before-definition
     628                       :file-name (compiler-warning-file-name w)
     629                       :function-name (compiler-warning-function-name w)
     630                       :source-note (compiler-warning-source-note w)
     631                       :warning-type :macro-used-before-definition
     632                       :args (list (car args)))))
     633             (setf (compiler-warning-stream-position w2)
     634                   (compiler-warning-stream-position w))
     635             w2)))))
     636
     637
    557638(defun report-deferred-warnings (&optional (file nil))
    558639  (let* ((current (ensure-merged-deferred-warnings *outstanding-deferred-warnings*))
    559640         (parent (deferred-warnings.parent current))
    560641         (warnings (deferred-warnings.warnings current))
    561          (defs (deferred-warnings.defs current))
    562642         (any nil)
    563643         (harsh nil))
     
    570650      (let* ((file nil)
    571651             (init t))
    572         (flet ((signal-warning (w)
    573                  (multiple-value-setq (harsh any file) (signal-compiler-warning w init file harsh any))
    574                  (setq init nil)))
    575           (dolist (w warnings)
    576             (let* ((args (compiler-warning-args w))
    577                    (wfname (car args))
    578                    (def nil))
    579               (when (if (typep w 'undefined-function-reference)
    580                       (not (setq def (or (gethash wfname defs)
    581                                          (let* ((global (fboundp wfname)))
    582                                            (if (typep global 'function)
    583                                              global))))))
    584                 (signal-warning w))
    585               ;; Check args in call to forward-referenced function.
    586               (if (or (typep def 'function)
    587                       (and (consp def)
    588                            (def-info.lfbits (cdr def))))
    589                 (when (cdr args)
    590                   (destructuring-bind (arglist spread-p)
    591                       (cdr args)
    592                     (multiple-value-bind (deftype reason)
    593                         (nx1-check-call-args def arglist spread-p)
    594                       (when deftype
    595                         (let* ((w2 (make-condition
    596                                     'invalid-arguments
    597                                     :file-name (compiler-warning-file-name w)
    598                                     :function-name (compiler-warning-function-name w)
    599                                     :warning-type deftype
    600                                     :args (list (car args) reason arglist spread-p))))
    601                           (setf (compiler-warning-stream-position w2)
    602                                 (compiler-warning-stream-position w))
    603                           (signal-warning w2))))))
    604                 (if (def-info.macro-p (cdr def))
    605                   (let* ((w2 (make-condition
    606                               'macro-used-before-definition
    607                               :file-name (compiler-warning-file-name w)
    608                               :function-name (compiler-warning-function-name w)
    609                               :warning-type :macro-used-before-definition
    610                               :args (list (car args)))))
    611                     (setf (compiler-warning-stream-position w2)
    612                           (compiler-warning-stream-position w))
    613                     (signal-warning w2)))))))))
     652        (dolist (w warnings)
     653          (when (setq w (verify-deferred-warning w))
     654            (multiple-value-setq (harsh any file) (signal-compiler-warning w init file harsh any))
     655            (setq init nil)))))
    614656    (values any harsh parent)))
    615657
  • branches/working-0711/ccl/lib/chars.lisp

    r11265 r12048  
    9191         (to-lower *upper-to-lower*))
    9292    (declare (type (mod #x110000) code)
    93              (type (simple-array (signed-byte 16) *to-lower)))
     93             (type (simple-array (signed-byte 16) (*)) to-lower))
    9494    (and (< code (length to-lower))
    9595         (not (zerop (aref to-lower code))))))
     
    565565                         len1 1))))
    566566    (if (typep string2 'simple-string)
    567       (setq len2 (length (the sumple-string string2)))
     567      (setq len2 (length (the simple-string string2)))
    568568      (etypecase string2
    569569        (string (setq len2 (length string2))
  • branches/working-0711/ccl/lib/defstruct-lds.lisp

    r10938 r12048  
    243243    (return
    244244     `(progn
     245        ,@(when (null (sd-type sd))
     246                `((when (memq ',struct-name *nx-known-declarations*)
     247                    (check-declaration-redefinition ',struct-name 'defstruct))))
    245248       (remove-structure-defs  ',struct-name) ; lose any previous defs
    246249        ,.(defstruct-slot-defs sd refnames env)
  • branches/working-0711/ccl/lib/encapsulate.lisp

    r11678 r12048  
    681681               &rest args) ; if methodp put &method on front of args - vs get-saved-method-var?
    682682       (declare (dynamic-extent args))
     683       (declare (ftype function ,def))
    683684       (let ((*trace-level* (1+ *trace-level*))
    684685             (,enable ,if))
  • branches/working-0711/ccl/lib/macros.lisp

    r11836 r12048  
    19961996                        (setq type-p t))
    19971997                      (setq type (cadr options))
    1998                       ;; complain about illegal typespecs
     1998                      ;; complain about illegal typespecs and continue
    19991999                      (handler-case (specifier-type type env)
    2000                         (invalid-type-specifier ()
     2000                        (program-error ()
    20012001                          (warn "Invalid type ~s in ~s slot definition ~s" type class-name slot))))
    20022002                     (:initform
     
    20502050                                      (length illegal) illegal keyvect))))
    20512051          `(progn
     2052             (when (memq ',class-name *nx-known-declarations*)
     2053               (check-declaration-redefinition ',class-name 'defclass))
    20522054            (eval-when (:compile-toplevel)
    20532055              (%compile-time-defclass ',class-name ,env)
  • branches/working-0711/ccl/lib/method-combination.lisp

    r11810 r12048  
    457457    (declare (fixnum bits numreq numopt))
    458458    (and (< i numopt)
    459          (< (the fixum (+ i numreq)) (length argvals)))))
     459         (< (the fixnum (+ i numreq)) (length argvals)))))
    460460
    461461;;; This assumes that we've checked for argument presence.
     
    465465         (numreq (ldb $lfbits-numreq bits)))
    466466    (declare (fixnum bits numreq ))
    467     (nth (the fixum (+ i numreq)) argvals)))
     467    (nth (the fixnum (+ i numreq)) argvals)))
    468468
    469469(defun gf-arguments-tail (gf argvals)
  • branches/working-0711/ccl/lib/nfcomp.lisp

    r11762 r12048  
    828828
    829829
    830 (defun fcomp-proclaim-type (type syms)
     830(defun fcomp-proclaim-type (type syms env)
    831831  (dolist (sym syms)
    832832    (if (symbolp sym)
    833     (push (cons sym type) *nx-compile-time-types*)
    834       (warn "~S isn't a symbol in ~S type declaration while compiling ~S."
    835             sym type *fasl-source-file*))))
     833      (progn
     834        (specifier-type-if-known type env :whine t)
     835        (push (cons sym type) *nx-compile-time-types*))
     836      (nx-bad-decls `(type ,type ,sym)))))
    836837
    837838(defun compile-time-proclamation (specs env &aux  sym (defenv (definition-environment env)))
     
    841842      (case sym
    842843        (type
    843          (fcomp-proclaim-type (car spec) (cdr spec)))
     844         (fcomp-proclaim-type (car spec) (cdr spec) env))
    844845        (special
    845846         (dolist (sym spec)
     
    880881             (push (list* (maybe-setf-function-name fname) sym ftype) (lexenv.fdecls defenv)))))
    881882        (otherwise
    882          (if (memq (if (consp sym) (%car sym) sym) *cl-types*)
    883            (fcomp-proclaim-type sym spec)       ; A post-cltl2 cleanup issue changes this
    884            nil)                         ; ---- probably ought to complain
    885          )))))
     883         (unless (memq sym *nx-known-declarations*)
     884           ;; Any type name is now (ANSI CL) a valid declaration.
     885           (if (symbolp sym)
     886             (fcomp-proclaim-type sym spec env)
     887             (nx-bad-decls `(,sym ,spec)))))))))
    886888
    887889(defun fcomp-load-%defun (form env)
     
    912914    (fcomp-random-toplevel-form form env)))
    913915
     916#-BOOTSTRAPPED (unless (fboundp 'note-type-info)
     917                 (fset 'note-type-info (nlambda bootstrapping-note-type-info (name kind env) (declare (ignore name kind env)))))
     918
     919
    914920(defun define-compile-time-structure (sd refnames predicate env)
    915921  (let ((defenv (definition-environment env)))
    916922    (when defenv
    917923      (when (non-nil-symbolp (sd-name sd))
     924        (note-type-info (sd-name sd) 'class env)
    918925        (push (make-instance 'compile-time-class :name (sd-name sd))
    919926              (defenv.classes defenv)))
     
    10861093                  (fcomp-digest-code-notes imm refs)))))))
    10871094
    1088 ; For now, defer only UNDEFINED-FUNCTION-REFERENCEs, signal all others via WARN.
     1095; For now, defer only UNDEFINED-REFERENCEs, signal all others via WARN.
    10891096; Well, maybe not WARN, exactly.
    10901097(defun fcomp-signal-or-defer-warnings (warnings env)
     
    10951102      (setf (compiler-warning-file-name w) *fasl-source-file*)
    10961103      (setf (compiler-warning-stream-position w) *fcomp-stream-position*)
    1097       (if (and (typep w 'undefined-function-reference)
     1104      (if (and (typep w 'undefined-reference)
    10981105               (eq w (setq w (macro-too-late-p w env))))
    10991106        (push w *fasl-deferred-warnings*)
     
    11111118  (let* ((args (compiler-warning-args w))
    11121119         (name (car args)))
    1113     (if (or (macro-function name)
    1114             (let* ((defenv (definition-environment env))
    1115                    (info (if defenv (assq name (defenv.functions defenv)))))
    1116               (and (consp (cdr info))
    1117                    (eq 'macro (cadr info)))))
    1118       (make-instance 'macro-used-before-definition
    1119         :file-name (compiler-warning-file-name w)
    1120         :function-name (compiler-warning-function-name w)
    1121         :warning-type ':macro-used-before-definition
    1122         :args args)
     1120    (if (typep w 'undefined-function-reference)
     1121      (if (or (macro-function name)
     1122              (let* ((defenv (definition-environment env))
     1123                     (info (if defenv (assq name (defenv.functions defenv)))))
     1124                (and (consp (cdr info))
     1125                     (eq 'macro (cadr info)))))
     1126          (make-instance 'macro-used-before-definition
     1127            :file-name (compiler-warning-file-name w)
     1128            :function-name (compiler-warning-function-name w)
     1129            :warning-type ':macro-used-before-definition
     1130            :args args)
     1131          w)
    11231132      w)))
    11241133
  • branches/working-0711/ccl/lib/sequences.lisp

    r11821 r12048  
    845845        (t (error "~S can't be coerced to type ~S." object output-type-spec))))))
    846846
     847(defun %coerce-to-string (seq)
     848   (let* ((len (length seq))
     849          (string (make-string len)))
     850     (declare (fixnum len) (simple-base-string string))
     851     (if (typep seq 'list)
     852       (do* ((l seq (cdr l))
     853             (i 0 (1+ i)))
     854            ((null l) string)
     855         (declare (list l) ; we know that it's a proper list because LENGTH won
     856                  (fixnum i))
     857         (setf (schar string i) (car l)))
     858       (dotimes (i len string)
     859         (setf (schar string i) (aref seq i))))))
     860
     861(defun %coerce-to-vector (seq subtype)
     862   (let* ((len (length seq))
     863          (vector (%alloc-misc len subtype)))
     864     (declare (fixnum len) (type (simple-array * (*)) vector))
     865     (if (typep seq 'list)
     866       (do* ((l seq (cdr l))
     867             (i 0 (1+ i)))
     868            ((null l) vector)
     869         (declare (list l) ; we know that it's a proper list because LENGTH won
     870                  (fixnum i))
     871         (setf (uvref vector i) (car l)))
     872       (dotimes (i len vector)
     873         (setf (uvref vector i) (aref seq i))))))
     874
     875(defun %coerce-to-list (seq)
     876  (if (typep seq 'list)
     877    seq
     878    (collect ((result))
     879      (dotimes (i (length seq) (result))
     880        (result (aref seq i))))))
     881
     882
     883
    847884
    848885(defun coerce-to-complex (object  output-type-spec)
Note: See TracChangeset for help on using the changeset viewer.