Changeset 12219


Ignore:
Timestamp:
Jun 7, 2009, 12:59:49 AM (10 years ago)
Author:
gz
Message:

Rename nx-the-typechecks to nx-declarations-typecheck, and typecheck all declarations when it's on.
Merged from r11819 r11820 r11822 r11823 r11824 r11836 r11836 r11837 r11850 r11851 r11852 r11853

Location:
trunk/source
Files:
13 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/X86/x862.lisp

    r12063 r12219  
    229229(declaim (fixnum *x862-vstack* *x862-cstack*))
    230230
    231  
     231
    232232
    233233
     
    13511351
    13521352(defun x862-set-vstack (new)
    1353   (setq *x862-vstack* new))
     1353  (setq *x862-vstack* (or new 0)))
    13541354
    13551355
     
    38103810
    38113811(defun x862-test-reg-%izerop (seg vreg xfer reg cr-bit true-p  zero)
    3812   (declare (fixnum reg zero))
     3812  (declare (fixnum zero))
    38133813  (with-x86-local-vinsn-macros (seg vreg xfer)
    38143814    (if (zerop zero)
     
    58385838                               (tail parsed-ops))
    58395839                          (declare (dynamic-extent parsed-ops)
    5840                                    (cons parsed-ops tail))
     5840                                   (list parsed-ops tail))
    58415841                          (dolist (op op-vals (apply (cadr f) parsed-ops))
    58425842                            (setq tail (cdr (rplaca tail (parse-operand-form op t)))))))
     
    61646164            (x862-save-nvrs seg pregs)
    61656165            (dolist (pair reglocatives)
    6166               (declare (cons pair))
    6167               (let* ((constant (car pair))
     6166              (let* ((pair pair)
     6167                     (constant (car pair))
    61686168                     (reg (cdr pair)))
    6169                 (declare (cons constant))
     6169                (declare (cons pair constant))
    61706170                (rplacd constant reg)
    61716171                (! ref-constant reg (x86-immediate-label (car constant))))))
     
    62006200                  (arg-reg-num (pop arg-reg-numbers) (pop arg-reg-numbers)))
    62016201                 ((null vars))
    6202               (declare (list vars) (fixnum arg-reg-num))
     6202              (declare (list vars))
    62036203              (let* ((var (car vars)))
    62046204                (when var
     
    89468946          (x862-form seg vreg xfer form)
    89478947          (with-note (form seg vreg xfer)
    8948             (let* ((ok (backend-get-next-label)))
    8949               (x862-one-targeted-reg-form seg form ($ *x862-arg-y*))
    8950               (x862-store-immediate seg typespec ($ *x862-arg-z*))
    8951               (x862-store-immediate seg 'typep ($ *x862-fname*))
    8952               (x862-set-nargs seg 2)
    8953               (x862-vpush-register seg ($ *x862-arg-y*))
    8954               (! call-known-symbol ($ *x862-arg-z*))
    8955               (! compare-to-nil ($ *x862-arg-z*))
    8956               (x862-vpop-register seg ($ *x862-arg-y*))
    8957               (! cbranch-false (aref *backend-labels* ok) x86::x86-e-bits)
    8958               (target-arch-case
    8959                (:x8632
    8960                 (let* ((*x862-vstack* *x862-vstack*)
    8961                        (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
    8962                   (! reserve-outgoing-frame)
    8963                   (incf *x862-vstack* (* 2 *x862-target-node-size*))
    8964                   (! vpush-fixnum (ash $XWRONGTYPE *x862-target-fixnum-shift*))
    8965                   (x862-store-immediate seg typespec ($ *x862-arg-z*))
    8966                   (x862-set-nargs seg 3)
    8967                   (! ksignalerr)))
    8968                (:x8664
    8969                 (x862-lri seg ($ x8664::arg_x) (ash $XWRONGTYPE *x862-target-fixnum-shift*))
     8948          (let* ((ok (backend-get-next-label)))
     8949            (if (and (symbolp typespec) (non-nil-symbolp (type-predicate typespec)))
     8950              ;; Do this so can compile the lisp with typechecking even though typep
     8951              ;; doesn't get defined til fairly late.
     8952              (progn
     8953                (x862-one-targeted-reg-form seg form ($ *x862-arg-z*))
     8954                (x862-store-immediate seg (type-predicate typespec) ($ *x862-fname*))
     8955                (x862-set-nargs seg 1)
     8956                (x862-vpush-register seg ($ *x862-arg-z*)))
     8957              (progn
     8958                (x862-one-targeted-reg-form seg form ($ *x862-arg-y*))
    89708959                (x862-store-immediate seg typespec ($ *x862-arg-z*))
    8971                 (x862-set-nargs seg 3)
    8972                 (! ksignalerr)))
    8973               (@ ok)
    8974               (<- ($ *x862-arg-y*))
    8975               (^))))))))
     8960                (x862-store-immediate seg 'typep ($ *x862-fname*))
     8961                (x862-set-nargs seg 2)
     8962                (x862-vpush-register seg ($ *x862-arg-y*))))
     8963            (! call-known-symbol ($ *x862-arg-z*))
     8964            (! compare-to-nil ($ *x862-arg-z*))
     8965            (x862-vpop-register seg ($ *x862-arg-y*))
     8966            (! cbranch-false (aref *backend-labels* ok) x86::x86-e-bits)
     8967            (target-arch-case
     8968             (:x8632
     8969              (let* ((*x862-vstack* *x862-vstack*)
     8970                     (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
     8971                (! reserve-outgoing-frame)
     8972                (incf *x862-vstack* (* 2 *x862-target-node-size*))
     8973                (! vpush-fixnum (ash $XWRONGTYPE *x862-target-fixnum-shift*))
     8974                (x862-store-immediate seg typespec ($ *x862-arg-z*))
     8975                (x862-set-nargs seg 3)
     8976                (! ksignalerr)))
     8977             (:x8664
     8978              (x862-lri seg ($ x8664::arg_x) (ash $XWRONGTYPE *x862-target-fixnum-shift*))
     8979              (x862-store-immediate seg typespec ($ *x862-arg-z*))
     8980              (x862-set-nargs seg 3)
     8981              (! ksignalerr)))
     8982            (@ ok)
     8983            (<- ($ *x862-arg-y*))
     8984            (^))))))))
    89768985         
    89778986         
  • trunk/source/compiler/backend.lisp

    r11958 r12219  
    379379    `(if ,regspec
    380380       (multiple-value-bind (,class ,regval) (regspec-class-and-value ,regspec hard-reg-class-gpr-crf-mask)
    381          (declare (fixnum ,class ,regval))
     381         (declare (fixnum ,class))
    382382         (if (= ,class hard-reg-class-crf)
    383383           ,crf-form
  • trunk/source/compiler/nx-basic.lisp

    r12161 r12219  
    146146                   (let* ((safety (safety-optimize-quantity env)))
    147147                     (or (eq safety 3)
    148                          (> safety (speed-optimize-quantity env)))))          ;the-typechecks
     148                         (> safety (speed-optimize-quantity env)))))          ;declarations-typecheck
    149149               #'(lambda (env)
    150150                   (neq (debug-optimize-quantity env) 3))   ; inline-self-calls
     
    171171                                   (force-boundp-checks nil fb-p)
    172172                                   (allow-constant-substitution nil acs-p)
    173                                    (the-typechecks nil tt-p))
     173                                   (declarations-typecheck nil dt-p))
    174174    (let ((p (copy-uvector policy)))
    175175      (if atr-p (setf (policy.allow-tail-recursion-elimination p) allow-tail-recursion-elimination))
     
    182182      (if fb-p (setf (policy.force-boundp-checks p) force-boundp-checks))
    183183      (if acs-p (setf (policy.allow-constant-substitution p) allow-constant-substitution))
    184       (if tt-p (setf (policy.the-typechecks p) the-typechecks))
     184      (if dt-p (setf (policy.declarations-typecheck p) declarations-typecheck))
    185185      p))
    186186  (defun %default-compiler-policy () policy))
  • trunk/source/compiler/nx0.lisp

    r12163 r12219  
    321321  (nx-apply-env-hook policy.allow-constant-substitution symbol value env))
    322322
    323 (defun nx-the-typechecks (env)
    324   (nx-apply-env-hook policy.the-typechecks env))
     323#-BOOTSTRAPPED
     324(eval-when (compile)
     325  (unless (boundp 'policy.declarations-typecheck)
     326    (load "ccl:library;lispequ.lisp")))
     327
     328(defun nx-declarations-typecheck (env)
     329  (nx-apply-env-hook policy.declarations-typecheck env))
     330
    325331
    326332#-bccl
     
    393399  (let* ((type t)
    394400         (*nx-form-type* (if (nx-trust-declarations env)
    395                            (dolist (decl (pending-declarations-vdecls pending)  type)
    396                             (when (and (eq (car decl) sym) (eq (cadr decl) 'type))
    397                               (setq type (nx1-type-intersect sym (nx-target-type type) (cddr decl)))))
     401                           (dolist (decl (pending-declarations-vdecls pending) type)
     402                             (when (and (eq (car decl) sym) (eq (cadr decl) 'type))
     403                               (setq type (nx1-type-intersect sym (nx-target-type type) (cddr decl)))))
    398404                           t)))
    399405    (nx1-typed-form form env)))
     
    977983    (when inittype (setf (var-inittype var) inittype))
    978984    (when (and (not (%ilogbitp $vbitspecial bits))
    979                (consp init))
     985               (acode-p init))
    980986      (let* ((op (acode-operator init)))
    981987        (if (eq op (%nx1-operator lexical-reference))
     
    14531459        (nx-effect-other-decls pending *nx-lexical-environment*)
    14541460        (setq body (nx1-env-body body old-env))
    1455         (nx1-punt-bindings (%car auxen) (%cdr auxen))         
     1461        (nx1-punt-bindings (%car auxen) (%cdr auxen))
    14561462        (when methvar
    14571463          (push methvar req)
     
    18981904      (if (eq type t)
    18991905        form
    1900         (list (%nx1-operator typed-form) type form)))))
     1906        (make-acode (%nx1-operator typed-form) type form)))))
    19011907
    19021908(defvar *format-arg-functions* '((format . 1) (format-to-string . 1) (error . 0) (warn . 0)
  • trunk/source/compiler/nx1.lisp

    r12071 r12219  
    5050     typespec
    5151     (nx1-transformed-form transformed env)
    52      (nx-the-typechecks env))))
     52     (nx-declarations-typecheck env))))
    5353
    5454(defnx1 nx1-struct-ref struct-ref (&whole whole structure offset)
     
    10171017    (nx-error "Odd number of forms in ~s ." whole))
    10181018  (while args
    1019     (let ((sym (nx-need-var (%car args) nil))
    1020           (val (%cadr args)))
     1019    (let* ((sym (nx-need-var (%car args) nil))
     1020           (val (%cadr args))
     1021           (declared-type (nx-declared-type sym env)))
     1022      (when (nx-declarations-typecheck env)
     1023        (unless (or (eq declared-type t)
     1024                    (and (consp val) (eq (%car val) 'the) (equal (cadr val) declared-type)))
     1025          (setq val `(the ,declared-type ,val))
     1026          (nx-note-source-transformation (caddr val) val)))
    10211027      (multiple-value-bind (expansion win) (macroexpand-1 sym env)
    10221028        (if win
    1023             (push (nx1-form `(setf ,expansion ,val)) res)
    1024             (multiple-value-bind (info inherited catchp)
     1029            (push (nx1-form `(setf ,expansion ,val)) res)
     1030            (multiple-value-bind (info inherited catchp)
    10251031                (nx-lex-info sym)
    10261032              (push
     
    10331039                                       (nx-var-bits catchp)))
    10341040                     (nx1-form `(setf ,inherited ,val)))
    1035                    (let* ((valtype (nx-form-type val env))
    1036                           (declared-type (nx-declared-type sym)))
     1041                   (let ((valtype (nx-form-type val env)))
    10371042                     (let ((*nx-form-type* declared-type))
    10381043                       (setq val (nx1-typed-form val env)))
     
    20232028
    20242029
    2025 (defun nx1-env-body (body old-env)
     2030(defun nx1-env-body (body old-env &optional (typecheck (nx-declarations-typecheck *nx-lexical-environment*)))
    20262031  (do* ((form (nx1-progn-body body))
     2032        (typechecks nil)
    20272033        (env *nx-lexical-environment* (lexenv.parent-env env)))
    2028        ((or (eq env old-env) (null env)) form)
     2034       ((or (eq env old-env) (null env))
     2035        (if typechecks
     2036          (make-acode
     2037           (%nx1-operator progn)
     2038           (nconc (nreverse typechecks) (list form)))
     2039          form))
    20292040    (let ((vars (lexenv.variables env)))
    2030       (if (consp vars)
     2041      (when (consp vars)
    20312042        (dolist (var vars)
    2032           (nx-check-var-usage var))))))
     2043          (nx-check-var-usage var)
     2044          (when (and typecheck
     2045                     (let ((expansion (var-expansion var)))
     2046                       (or (atom expansion) (neq (%car expansion) :symbol-macro))))
     2047            (let* ((sym (var-name var))
     2048                   (type (nx-declared-type sym)))
     2049              (unless (eq type t)
     2050                (let ((old-bits (nx-var-bits var)))
     2051                  (push (nx1-form `(the ,type ,sym)) typechecks)
     2052                  (when (%izerop (%ilogand2 old-bits
     2053                                            (%ilogior (%ilsl $vbitspecial 1)
     2054                                                      (%ilsl $vbitreffed 1)
     2055                                                      (%ilsl $vbitclosed 1)
     2056                                                      $vrefmask
     2057                                                      $vsetqmask)))
     2058                    (nx-set-var-bits var (%ilogand2 (nx-var-bits var)
     2059                                                    (%ilognot (%ilsl $vbitignore 1))))))))))))))
     2060
    20332061
    20342062(defnx1 nx1-let* (let*) (varspecs &body forms)
     
    20782106            (push (nx-new-var pending sym t) vars))
    20792107          (nx-effect-other-decls pending *nx-lexical-environment*)
    2080           (make-acode 
     2108          (make-acode
    20812109           (%nx1-operator multiple-value-bind)
    20822110           (nreverse vars)
  • trunk/source/compiler/optimizers.lisp

    r12215 r12219  
    514514             ,@decls
    515515             (declare (fixnum ,limit)
    516                       (type (integer 0 ,(if (<= upper 0) 0 `(,upper))) ,i)
     516                      (type (integer 0 ,(if (<= upper 0) 0 upper)) ,i)
    517517                      (unsettable ,i))
    518518             (block nil
     
    739739                    (t                        ;Should do more here
    740740                     (comp-make-uarray dims keys (type-keyword-code element-type-keyword)))))
    741              (type (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)))
     741             (type (if (nx-trust-declarations env)
     742                     (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)
     743                     t)))
    742744        `(the ,type ,expansion)))
    743745
     
    941943              (setq ctype (specifier-type-if-known type env :whine t)))
    942944         (cond ((nx-form-typep arg type env) arg)
    943                ((eq type 'simple-vector)
    944                 `(the simple-vector (require-simple-vector ,arg)))
    945                ((eq type 'simple-string)
    946                 `(the simple-string (require-simple-string ,arg)))
    947                ((eq type 'integer)
    948                 `(the integer (require-integer ,arg)))
    949                ((eq type 'fixnum)
    950                 `(the fixnum (require-fixnum ,arg)))
    951                ((eq type 'real)
    952                 `(the real (require-real ,arg)))
    953                ((eq type 'list)
    954                 `(the list (require-list ,arg)))
    955                ((eq type 'character)
    956                 `(the character (require-character ,arg)))
    957                ((eq type 'number)
    958                 `(the number (require-number ,arg)))
    959                ((eq type 'symbol)
    960                 `(the symbol (require-symbol ,arg)))
    961                ((type= ctype
    962                        (specifier-type '(signed-byte 8)))
    963                 `(the (signed-byte 8) (require-s8 ,arg)))
    964                ((type= ctype
    965                        (specifier-type '(unsigned-byte 8)))
    966                 `(the (unsigned-byte 8) (require-u8 ,arg)))
    967                ((type= ctype
    968                        (specifier-type '(signed-byte 16)))
    969                 `(the (signed-byte 16) (require-s16 ,arg)))
    970                ((type= ctype
    971                        (specifier-type '(unsigned-byte 16)))
    972                 `(the (unsigned-byte 16) (require-u16 ,arg)))
    973                ((type= ctype
    974                        (specifier-type '(signed-byte 32)))
    975                 `(the (signed-byte 32) (require-s32 ,arg)))
    976                ((type= ctype
    977                        (specifier-type '(unsigned-byte 32)))
    978                 `(the (unsigned-byte 32) (require-u32 ,arg)))
    979                ((type= ctype
    980                        (specifier-type '(signed-byte 64)))
    981                 `(the (signed-byte 64) (require-s64 ,arg)))
    982                ((type= ctype
    983                        (specifier-type '(unsigned-byte 64)))
    984                 `(the (unsigned-byte 64) (require-u64 ,arg)))
    985                #+nil
    986                ((and (symbolp type)
    987                      (let ((simpler (type-predicate type)))
    988                        (if simpler `(the ,type (%require-type ,arg ',simpler))))))
    989                #+nil
    990                ((and (symbolp type)(find-class type nil env))
    991                   `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t))))
     945               ((and (nx-trust-declarations env) ;; if don't trust declarations, don't bother.
     946                     (cond ((eq type 'simple-vector)
     947                            `(the simple-vector (require-simple-vector ,arg)))
     948                           ((eq type 'simple-string)
     949                            `(the simple-string (require-simple-string ,arg)))
     950                           ((eq type 'integer)
     951                            `(the integer (require-integer ,arg)))
     952                           ((eq type 'fixnum)
     953                            `(the fixnum (require-fixnum ,arg)))
     954                           ((eq type 'real)
     955                            `(the real (require-real ,arg)))
     956                           ((eq type 'list)
     957                            `(the list (require-list ,arg)))
     958                           ((eq type 'character)
     959                            `(the character (require-character ,arg)))
     960                           ((eq type 'number)
     961                            `(the number (require-number ,arg)))
     962                           ((eq type 'symbol)
     963                            `(the symbol (require-symbol ,arg)))
     964                           ((type= ctype
     965                                   (specifier-type '(signed-byte 8)))
     966                            `(the (signed-byte 8) (require-s8 ,arg)))
     967                           ((type= ctype
     968                                   (specifier-type '(unsigned-byte 8)))
     969                            `(the (unsigned-byte 8) (require-u8 ,arg)))
     970                           ((type= ctype
     971                                   (specifier-type '(signed-byte 16)))
     972                            `(the (signed-byte 16) (require-s16 ,arg)))
     973                           ((type= ctype
     974                                   (specifier-type '(unsigned-byte 16)))
     975                            `(the (unsigned-byte 16) (require-u16 ,arg)))
     976                           ((type= ctype
     977                                   (specifier-type '(signed-byte 32)))
     978                            `(the (signed-byte 32) (require-s32 ,arg)))
     979                           ((type= ctype
     980                                   (specifier-type '(unsigned-byte 32)))
     981                            `(the (unsigned-byte 32) (require-u32 ,arg)))
     982                           ((type= ctype
     983                                   (specifier-type '(signed-byte 64)))
     984                            `(the (signed-byte 64) (require-s64 ,arg)))
     985                           ((type= ctype
     986                                   (specifier-type '(unsigned-byte 64)))
     987                            `(the (unsigned-byte 64) (require-u64 ,arg)))
     988                           #+nil
     989                           ((and (symbolp type)
     990                                 (let ((simpler (type-predicate type)))
     991                                   (if simpler `(the ,type (%require-type ,arg ',simpler))))))
     992                           #+nil
     993                           ((and (symbolp type)(find-class type nil env))
     994                            `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t))))
     995                           (t (let* ((val (gensym)))
     996                                `(the ,type
     997                                   (let* ((,val ,arg))
     998                                     (if (typep ,val ',type)
     999                                       ,val
     1000                                       (%kernel-restart $xwrongtype ,val ',type)))))))))
    9921001               (t (let* ((val (gensym)))
    9931002                    `(let* ((,val ,arg))
    994                       (if (typep ,val ',type)
    995                         ,val
    996                         (%kernel-restart $xwrongtype ,val ',type)))))))
     1003                       (if (typep ,val ',type)
     1004                         ,val
     1005                         (%kernel-restart $xwrongtype ,val ',type)))))))
    9971006        (t call)))
    9981007
  • trunk/source/level-1/l1-clos-boot.lisp

    r12215 r12219  
    12401240
    12411241(defun std-instance-class-cell-typep (form class-cell)
    1242   (declare (type class-cell  class-cell))
    12431242  (let* ((typecode (typecode form))
    12441243         (wrapper (cond ((= typecode target::subtag-instance)
  • trunk/source/level-1/l1-error-system.lisp

    r12045 r12219  
    10781078        (cons $xfunbnd 'undefined-function)
    10791079        (cons $xbadkeys 'simple-program-error)
     1080        (cons $xcallnomatch 'simple-program-error)
    10801081        (cons $xnotfun 'call-special-operator-or-macro)
    10811082        (cons $xaccessnth 'sequence-index-type-error)
  • trunk/source/level-1/l1-lisp-threads.lisp

    r12210 r12219  
    657657
    658658(defun %ptr-in-area-p (ptr area)
    659   (declare (fixnum ptr area))           ; lie, maybe
     659  (declare (optimize (speed 3) (safety 0)) (fixnum ptr area))           ; lie, maybe
    660660  (and (<= (the fixnum (%fixnum-ref area target::area.low)) ptr)
    661661       (> (the fixnum (%fixnum-ref area target::area.high)) ptr)))
  • trunk/source/lib/defstruct.lisp

    r12163 r12219  
    251251          (if (specifier-type-if-known type env)
    252252            `(the ,type ,accessor)
    253             (if (nx-the-typechecks env)
     253            (if (nx-declarations-typecheck env)
    254254              `(require-type ,accessor ',type)
    255255              ;; Otherwise just ignore the type, it's most likely a forward reference,
  • trunk/source/lib/lists.lisp

    r11183 r12219  
    783783    (declare (dynamic-extent arglists args ret-list))
    784784    (let ((argstail arglists))
    785       (declare (cons argstail))
    786785      (dolist (arg original-arglists)
    787         (setf (car argstail) arg)
     786        (setf (car (the cons argstail)) arg)
    788787        (pop argstail)))
    789788    (do ((res nil)
    790789         (argstail args args))
    791         ((memq nil arglists)           
     790        ((memq nil arglists)
    792791         (if accumulate
    793792             (cdr ret-list)
    794793             (car original-arglists)))
    795       (declare (cons argstail))
    796794      (do ((l arglists (cdr l)))
    797795          ((not l))
    798         (setf (car argstail) (if take-car (car (car l)) (car l)))
     796        (setf (car (the cons argstail)) (if take-car (car (car l)) (car l)))
    799797        (rplaca l (cdr (car l)))
    800798        (pop argstail))
  • trunk/source/library/lispequ.lisp

    r11600 r12219  
    199199  (var-bits var-parent)                 ; fixnum or ptr to parent
    200200  (var-ea  var-expansion)               ; p2 address (or symbol-macro expansion)
    201   var-decls                             ; list of applicable decls
     201  var-decls                             ; list of applicable decls [not used]
    202202  var-inittype
    203203  var-binding-info
     
    15591559  policy.open-code-inline
    15601560  policy.inhibit-safety-checking
    1561   policy.the-typechecks
     1561  policy.declarations-typecheck
    15621562  policy.inline-self-calls
    15631563  policy.allow-transforms
  • trunk/source/library/loop.lisp

    r12215 r12219  
    10631063
    10641064(defun loop-typed-init (data-type)
    1065   (when (and data-type (subtypep data-type 'number))
    1066     (if (or (subtypep data-type 'float) (subtypep data-type '(complex float)))
    1067         (coerce 0 data-type)
    1068         0)))
     1065  (when data-type
     1066    (let ((val (if (subtypep data-type 'number)
     1067                 (if (or (subtypep data-type 'float) (subtypep data-type '(complex float)))
     1068                   (coerce 0 data-type)
     1069                   0)
     1070                 (if (subtypep data-type 'character)
     1071                   #\Null
     1072                   nil))))
     1073      (and val (typep val data-type) val))))
    10691074
    10701075
     
    11581163         (unless (symbolp name)
    11591164           (loop-error "Bad variable ~S somewhere in LOOP." name))
     1165         (unless initialization (setq initialization (loop-typed-init dtype)))
     1166         (when (and dtype
     1167                    (null initialization)
     1168                    (not (typep nil dtype)))
     1169           (if (eq dtype 'complex)
     1170             (setq initialization 0 dtype 'number)
     1171             (when iteration-variable-p
     1172               (setq dtype `(or null ,dtype)))))
    11601173         (loop-declare-variable name dtype)
    11611174         ;; We use ASSOC on this list to check for duplications (above),
    11621175         ;; so don't optimize out this list:
    1163          (push (list name (or initialization (loop-typed-init dtype)))
    1164                *loop-variables*))
     1176         (push (list name initialization) *loop-variables*))
    11651177        (initialization
    11661178         (cond (*loop-destructuring-hooks*
     
    16241636    (let ((listvar var))
    16251637      (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type))
    1626             (t (loop-make-variable (setq listvar (loop-gentemp)) list 'list)
     1638            (t (loop-make-variable (setq listvar (loop-gentemp)) list nil)
    16271639               (loop-make-iteration-variable var nil data-type)))
    1628       (multiple-value-bind (list-step step-function) (loop-list-step listvar)
     1640      (multiple-value-bind (list-step step-function) (loop-list-step `(the cons ,listvar))
    16291641        (declare (ignore step-function))
    16301642        ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind.
     
    16431655                 `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest
    16441656                   () () () ,first-endtest ()))
    1645                 (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step)))
     1657                (t (let ((step `(,var (the cons ,listvar))) (pseudo `(,listvar ,list-step)))
    16461658                     `(,other-endtest ,step () ,pseudo
    16471659                       ,@(and (not (eq first-endtest other-endtest))
Note: See TracChangeset for help on using the changeset viewer.