Changeset 10942 for trunk/source/level-1


Ignore:
Timestamp:
Oct 2, 2008, 6:43:48 PM (12 years ago)
Author:
gz
Message:

Propagate r10938:r10941 (duplicate definition warnings) to trunk

Location:
trunk/source/level-1
Files:
14 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-application.lisp

    r10914 r10942  
    304304  #+unix '("home:ccl-init" "home:\\.ccl-init")
    305305  #+windows "home:ccl-init")
    306 
    307 (defmethod application-error ((a application) condition error-pointer)
    308   (declare (ignore condition error-pointer))
    309   (quit))
  • trunk/source/level-1/l1-callbacks.lisp

    r10629 r10942  
    2121(defstatic *callback-lock* (make-lock))
    2222
    23 
    24 ;;; MacOS toolbox routines were once written mostly in Pascal, so some
    25 ;;; code still refers to callbacks from foreign code as "pascal-callable
    26 ;;; functions".
    27 
    28 ; %Pascal-Functions% Entry
    29 (def-accessor-macros %svref
    30   pfe.routine-descriptor
    31   pfe.proc-info
    32   pfe.lisp-function
    33   pfe.sym
    34   pfe.without-interrupts
    35   pfe.trace-p)
    36 
    37 (defun %cons-pfe (routine-descriptor proc-info lisp-function sym without-interrupts)
    38   (vector routine-descriptor proc-info lisp-function sym without-interrupts nil))
    3923
    4024;;; (defcallback ...) expands into a call to this function.
  • trunk/source/level-1/l1-clos-boot.lisp

    r10937 r10942  
    175175
    176176
    177 (defun %slot-definition-class (slotd)
    178   (standard-slot-definition.class slotd))
    179 
    180177(defun %slot-definition-location (slotd)
    181178  (standard-effective-slot-definition.location slotd))
     
    279276
    280277;;; This becomes (apply #'make-instance <method-class> &rest args).
    281 (defun %make-method-instance (class &key
    282                                     qualifiers
    283                                     specializers
    284                                     function                               
    285                                     name
    286                                     lambda-list
    287                                     &allow-other-keys)
    288   (let* ((method
    289           (%instance-vector (%class-own-wrapper class)
    290                             qualifiers
    291                             specializers
    292                             function
    293                             nil
    294                             name
    295                             lambda-list)))
    296     (when function
    297       (let* ((inner (closure-function function)))
    298         (unless (eq inner function)
    299           (copy-method-function-bits inner function)))
    300       (lfun-name function method))
    301     method))
     278(fset '%make-method-instance
     279      (nlambda bootstrapping-%make-method-instance (class &key
     280                                                          qualifiers
     281                                                          specializers
     282                                                          function
     283                                                          name
     284                                                          lambda-list
     285                                                          &allow-other-keys)
     286        (let* ((method
     287                (%instance-vector (%class-own-wrapper class)
     288                                  qualifiers
     289                                  specializers
     290                                  function
     291                                  nil
     292                                  name
     293                                  lambda-list)))
     294          (when function
     295            (let* ((inner (closure-function function)))
     296              (unless (eq inner function)
     297                (copy-method-function-bits inner function)))
     298            (lfun-name function method))
     299          method)))
    302300 
    303301       
     
    872870
    873871;; Redefined in l1-clos.lisp
    874 (defun maybe-remove-make-instance-optimization (gfn method)
    875   (declare (ignore gfn method))
    876   nil)
     872(fset 'maybe-remove-make-instance-optimization
     873      (nlambda bootstrapping-maybe-remove-make-instance-optimization (gfn method)
     874        (declare (ignore gfn method))
     875        nil))
    877876
    878877(defun %add-standard-method-to-standard-gf (gfn method)
     
    13281327
    13291328
    1330 (defun set-find-class (name class)
    1331   (clear-type-cache)
    1332   (let* ((cell (find-class-cell name t))
    1333          (old-class (class-cell-class cell)))
    1334     (when class
    1335       (if (eq name (%class.name class))
    1336         (setf (info-type-kind name) :instance)))
    1337     (setf (class-cell-class cell) class)
    1338     (update-class-proper-names name old-class class)
    1339     class))
     1329(fset 'set-find-class (nfunction bootstrapping-set-find-class ; redefined below
     1330                                 (lambda (name class)
     1331                                   (clear-type-cache)
     1332                                   (let* ((cell (find-class-cell name t))
     1333                                          (old-class (class-cell-class cell)))
     1334                                     (when class
     1335                                       (if (eq name (%class.name class))
     1336                                         (setf (info-type-kind name) :instance)))
     1337                                     (setf (class-cell-class cell) class)
     1338                                     (update-class-proper-names name old-class class)
     1339                                     class))))
    13401340
    13411341
    13421342;;; bootstrapping definition. real one is in "sysutils.lisp"
    1343 
    1344 (defun built-in-type-p (name)
    1345   (or (type-predicate name)
    1346       (memq name '(signed-byte unsigned-byte mod
    1347                    values satisfies member and or not))
    1348       (typep (find-class name nil) 'built-in-class)))
     1343(fset 'built-in-type-p (nfunction boostrapping-built-in-typep-p
     1344                                  (lambda (name)
     1345                                    (or (type-predicate name)
     1346                                        (memq name '(signed-byte unsigned-byte mod
     1347                                                     values satisfies member and or not))
     1348                                        (typep (find-class name nil) 'built-in-class)))))
    13491349
    13501350
     
    25192519;;; Bootstrapping version of union
    25202520(unless (fboundp 'union)
    2521 (defun union (l1 l2)
    2522   (dolist (e l1)
    2523     (unless (memq e l2)
    2524       (push e l2)))
    2525   l2)
     2521  (fset 'union (nlambda bootstrapping-union (l1 l2)
     2522                 (dolist (e l1)
     2523                   (unless (memq e l2)
     2524                     (push e l2)))
     2525                 l2))
    25262526)
    25272527
  • trunk/source/level-1/l1-clos.lisp

    r10426 r10942  
    176176
    177177;; Bootstrapping version, replaced in l1-typesys
    178 (defun standardized-type-specifier (spec)
    179   (when (and (consp spec)
    180              (memq (%car spec) '(and or))
    181              (consp (%cdr spec))
    182              (null (%cddr spec)))
    183     (setq spec (%cadr spec)))
    184   (if (consp spec)
    185     (cons (%car spec) (mapcar #'standardized-type-specifier (%cdr spec)))
    186     (or (cdr (assoc spec '((string . base-string))))
    187         spec)))
     178(fset 'standardized-type-specifier
     179      (nlambda bootstrapping-standardized-type-specifier (spec)
     180        (when (and (consp spec)
     181                   (memq (%car spec) '(and or))
     182                   (consp (%cdr spec))
     183                   (null (%cddr spec)))
     184          (setq spec (%cadr spec)))
     185        (if (consp spec)
     186          (cons (%car spec) (mapcar #'standardized-type-specifier (%cdr spec)))
     187          (or (cdr (assoc spec '((string . base-string))))
     188              spec))))
    188189
    189190;;; The type of an effective slot definition is the intersection of
     
    11851186
    11861187
    1187 ;;; Fake method-combination
     1188;;; Fake method-combination, redefined in lib;method-combination.
    11881189(defclass method-combination (metaobject)
    1189   ((name :accessor method-combination-name :initarg :name)))
     1190  ((name :initarg :name)))
    11901191
    11911192
  • trunk/source/level-1/l1-dcode.lisp

    r10426 r10942  
    611611  (sgf.method-combination gf))
    612612
    613 (defun %combined-method-methods  (cm)
    614   (combined-method.thing cm))
    615 
    616 (defun %combined-method-dcode (cm)
    617   ;(require-type cm 'combined-method)
    618   (combined-method.dcode cm))
    619 
    620 
    621613; need setters too
    622614
  • trunk/source/level-1/l1-files.lisp

    r10872 r10942  
    128128
    129129                   
    130 (defun %shrink-vector (vector to-size)
    131   (cond ((eq (length vector) to-size)
    132          vector)
    133         ((array-has-fill-pointer-p vector)
    134          (setf (fill-pointer vector) to-size)
    135          vector)
    136         (t (subseq vector 0 to-size))))
    137 
    138130(defun namestring-unquote (name)
    139131  #+(and windows-target bogus)
     
    258250
    259251
    260 (defun pathname-host (thing)  ; redefined later in this file
    261   (declare (ignore thing))
    262   :unspecific)
    263 
    264 (defun pathname-version (thing)  ; redefined later in this file
    265   (declare (ignore thing))
    266   nil)
     252(fset 'pathname-host (nfunction bootstrapping-pathname-host   ; redefined later in this file
     253                                (lambda (thing)
     254                                  (declare (ignore thing))
     255                                  :unspecific)))
     256
     257(fset 'pathname-version (nfunction bootstrapping-pathname-version   ; redefined later in this file
     258                                   (lambda (thing)
     259                                     (declare (ignore thing))
     260                                     nil)))
    267261
    268262(defmethod print-object ((pathname pathname) stream)
  • trunk/source/level-1/l1-format.lisp

    r10426 r10942  
    4848(defun pop-format-arg (&aux (args *format-arguments*))
    4949  (if (null args)
    50       (format-error "Missing argument"))
    51     (progn
    52      (setq *format-arguments* (cdr args))
    53      (%car args)))
     50    (format-error "Missing argument"))
     51  (progn
     52    (setq *format-arguments* (cdr args))
     53    (%car args)))
    5454 
    5555;SUB-FORMAT parses (a range of) the control string, finding the directives
     
    292292
    293293;;;This function is shadowed by CCL in order to use ~{ to print error messages.
    294 (defun format (stream control-string &rest format-arguments)
    295   (declare (dynamic-extent format-arguments))
    296   (when (null stream)
    297    (return-from format
    298     (with-output-to-string (x)
    299      (apply #'format x control-string format-arguments))))
    300   (if (eq stream t)
    301     (setq stream *standard-output*)
    302     (unless (streamp stream) (report-bad-arg stream 'stream)))
    303   (if (functionp control-string)
    304     (apply control-string stream format-arguments)
    305     (progn
    306       (setq control-string (ensure-simple-string control-string))
    307       (let* ((*format-original-arguments* format-arguments)
    308              (*format-arguments* format-arguments)
    309              (*format-control-string* control-string))
    310         (catch 'format-escape
    311          (sub-format stream 0 (length control-string)))
    312         nil))))
    313 
    314 (defun format-error (&rest args)
    315    (format t "~&FORMAT error at position ~A in control string ~S "
    316              *format-index* *format-control-string*)
    317    (apply #'error args))
     294(fset 'format
     295      (nlambda bootstrapping-format (stream control-string &rest format-arguments)
     296        (declare (dynamic-extent format-arguments))
     297        (block format
     298          (when (null stream)
     299            (return-from format
     300              (with-output-to-string (x)
     301                (apply #'format x control-string format-arguments))))
     302          (if (eq stream t)
     303            (setq stream *standard-output*)
     304            (unless (streamp stream) (report-bad-arg stream 'stream)))
     305          (if (functionp control-string)
     306            (apply control-string stream format-arguments)
     307            (progn
     308              (setq control-string (ensure-simple-string control-string))
     309              (let* ((*format-original-arguments* format-arguments)
     310                     (*format-arguments* format-arguments)
     311                     (*format-control-string* control-string))
     312                (catch 'format-escape
     313                  (sub-format stream 0 (length control-string)))
     314                nil))))))
     315
     316(fset 'format-error
     317      (nlambda bootstrapping-format-error (&rest args)
     318        (format t "~&FORMAT error at position ~A in control string ~S "
     319                *format-index* *format-control-string*)
     320        (apply #'error args)))
    318321
    319322(defun format-no-flags (colon atsign)
  • trunk/source/level-1/l1-pathnames.lisp

    r10872 r10942  
    435435                    (when (null (cdr dir))
    436436                      (setq dir (car dir))
    437                       (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors)))))
    438     (cond ((eq path wild) t)
    439           ((only-wild wild)
    440            t)
    441           (t (let ((result t))
    442                (block nil
    443                  (while (and path wild)
    444                    (let ((pathstr (car path))
    445                          (wildstr (car wild)))
    446                      (case wildstr
    447                        (:wild (setq wildstr "*"))
    448                        (:wild-inferiors (setq wildstr "**")))
    449                      (case pathstr
    450                        (:wild (setq pathstr "*"))
    451                        (:wild-inferiors (setq pathstr "**")))
    452                      (when (not
    453                             (cond ((string= wildstr "**")
    454                                    (setq result (%pathname-match-dir1 path (cdr wild)))
    455                                    (return-from nil))
    456                                   ((%path-str*= pathstr wildstr))))
    457                        (setq result nil)
    458                        (return-from nil))
    459                      (setq wild (cdr wild) path (cdr path))))
    460                  (when (and (or path wild)(not (only-wild wild)))
    461                    (setq result nil)))
    462                result)))))
    463 
    464 (defun %pathname-match-dir0 (path wild)
    465   (flet ((only-wild (dir)
    466                     (when (null (cdr dir))
    467                       (setq dir (car dir))
    468437                      (when (consp dir) (setq dir (cadr dir)))
    469438                      (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors)))))
  • trunk/source/level-1/l1-readloop.lisp

    r10426 r10942  
    404404    lambda-expression))
    405405
     406
     407(defun %cons-def-info (type &optional lfbits keyvect lambda specializers qualifiers)
     408  (ecase type
     409    (defun nil)
     410    (defmacro (setq lambda '(macro) lfbits nil)) ;; some code assumes lfbits=nil
     411    (defgeneric (setq lambda (list :methods)))
     412    (defmethod (setq lambda (list :methods (cons qualifiers specializers)))))
     413  (vector lfbits keyvect *loading-file-source-file* lambda))
     414
     415(defun def-info.lfbits (def-info)
     416  (and def-info (svref def-info 0)))
     417
     418(defun def-info.keyvect (def-info)
     419  (and def-info (svref def-info 1)))
     420
     421(defun def-info.file (def-info)
     422  (and def-info (svref def-info 2)))
     423
     424(defun def-info.lambda (def-info)
     425  (let ((data (and def-info (svref def-info 3))))
     426    (and (eq (car data) 'lambda) data)))
     427
     428(defun def-info.methods (def-info)
     429  (let ((data (and def-info (svref def-info 3))))
     430    (and (eq (car data) :methods) (%cdr data))))
     431
     432(defun def-info-with-new-methods (def-info new-methods)
     433  (unless (eq (def-info.type def-info) 'defgeneric) (error "Bug: not method info: ~s" def-info))
     434  (if (eq new-methods (def-info.methods def-info))
     435    def-info
     436    (let ((new (copy-seq def-info)))
     437      (setf (svref new 3) (cons :methods new-methods))
     438      new)))
     439
     440(defun def-info.macro-p (def-info)
     441  (let ((data (and def-info (svref def-info 2))))
     442    (eq (car data) 'macro)))
     443
     444(defun def-info.type (def-info)
     445  (if (null def-info) nil  ;; means FTYPE decl or lap function
     446    (let ((data (svref def-info 3)))
     447      (ecase (car data)
     448        ((nil lambda) 'defun)
     449        (:methods 'defgeneric)
     450        (macro 'defmacro)))))
     451
     452(defparameter *one-arg-defun-def-info* (%cons-def-info 'defun (encode-lambda-list '(x))))
     453
     454(defvar *compiler-warn-on-duplicate-definitions* t)
     455
     456(defun combine-function-infos (name old-info new-info)
     457  (let ((old-type (def-info.type old-info))
     458        (new-type (def-info.type new-info)))
     459    (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric))
     460           ;; TODO: Check compatibility of lfbits...
     461           ;; TODO: check that all methods implement defgeneric keys
     462           (let ((old-methods (def-info.methods old-info))
     463                 (new-methods (def-info.methods new-info)))
     464             (loop for new-method in new-methods
     465                   do (if (member new-method old-methods :test #'equal)
     466                        (when *compiler-warn-on-duplicate-definitions*
     467                          (nx1-whine :duplicate-definition
     468                                     `(method ,@(car new-method) ,name ,(cdr new-method))
     469                                     (def-info.file old-info)
     470                                     (def-info.file new-info)))
     471                        (push new-method old-methods)))
     472             (def-info-with-new-methods old-info old-methods)))
     473          ((or (eq (or old-type 'defun) (or new-type 'defun))
     474               (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
     475           (when (and old-type new-type *compiler-warn-on-duplicate-definitions*)
     476             (nx1-whine :duplicate-definition name (def-info.file old-info) (def-info.file new-info)))
     477           (or new-info old-info))
     478          (t
     479           (when *compiler-warn-on-duplicate-definitions*
     480             (apply #'nx1-whine :duplicate-definition
     481                    name
     482                    (def-info.file old-info)
     483                    (def-info.file new-info)
     484                    (cond ((eq old-type 'defmacro) '("macro" "function"))
     485                          ((eq new-type 'defmacro) '("function" "macro"))
     486                          ((eq old-type 'defgeneric) '("generic function" "function"))
     487                          (t '("function" "generic function")))))
     488           new-info))))
     489
     490(defun record-function-info (name info env)
     491  (let* ((definition-env (definition-environment env)))
     492    (if definition-env
     493      (let* ((defs (defenv.defined definition-env))
     494             (already (if (listp defs) (assq name defs) (gethash name defs))))
     495        (if already
     496          (setf (%cdr already) (combine-function-infos name (%cdr already) info))
     497          (let ((new (cons name info)))
     498            (if (listp defs)
     499              (setf (defenv.defined definition-env) (cons new defs))
     500              (setf (gethash name defs) new))))
     501        info))))
     502
     503
    406504;;; This is different from AUGMENT-ENVIRONMENT.
    407 ;;; If "info" is a lambda expression, then
    408 ;;;  record a cons whose CAR is (encoded-lfun-bits . keyvect) and whose cdr
    409 ;;;  is the lambda expression iff the function named by "name" is
    410 ;;;  declared/proclaimed INLINE in env
    411505(defun note-function-info (name lambda-expression env)
    412506  (let* ((info nil)
     
    414508    (when (lambda-expression-p lambda-expression)
    415509      (multiple-value-bind (lfbits keyvect) (encode-lambda-list (cadr lambda-expression) t)
    416         (setq info (cons (cons lfbits keyvect)
    417                          (retain-lambda-expression name lambda-expression env)))))
     510        (setq info (%cons-def-info 'defun lfbits keyvect
     511                                   (retain-lambda-expression name lambda-expression env)))))
    418512    (record-function-info name info env))
    419513  name)
     
    422516(defun retrieve-environment-function-info (name env)
    423517 (let ((defenv (definition-environment env)))
    424    (if defenv (assq (maybe-setf-function-name name) (defenv.defined defenv)))))
     518   (when defenv
     519     (let ((defs (defenv.defined defenv))
     520           (sym (maybe-setf-function-name name)))
     521       (if (listp defs) (assq sym defs) (gethash sym defs))))))
    425522
    426523(defun maybe-setf-function-name (name)
  • trunk/source/level-1/l1-streams.lisp

    r10822 r10942  
    43054305  (%string-push-extend char (string-stream-ioblock-string ioblock)))
    43064306
    4307 (defmethod stream-force-output ((stream string-output-stream)) nil)
    4308 
    43094307(defun fill-pointer-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
    43104308  (let* ((end (+ start-char num-chars))
  • trunk/source/level-1/l1-typesys.lisp

    r10818 r10942  
    34463446                                     '(args-ctype values-ctype function-ctype))))
    34473447
    3448 (defun function-ctype-p (x) (istruct-typep x 'function-ctype))
    34493448(defun valuec-ctype-p (x) (istruct-typep x 'values-ctype))
    34503449
  • trunk/source/level-1/l1-utils.lisp

    r10712 r10942  
    9292;;; to avoid clutter - done
    9393
    94 (defun physical-pathname-p (file)(declare (ignore file)) nil) ; redefined later
     94(fset 'physical-pathname-p (lambda (file)(declare (ignore file)) nil)) ; redefined later
    9595
    9696
    9797;(%defvar *enqueued-window-title* nil)
    9898
    99 (defun booted-probe-file (file)
    100   (declare (ignore file))
    101   nil)
     99(fset 'booted-probe-file (lambda (file) (declare (ignore file)) nil))
    102100
    103101(queue-fixup
  • trunk/source/level-1/sysutils.lisp

    r10937 r10942  
    528528(defparameter *outstanding-deferred-warnings* nil)
    529529
    530 
    531 (defun %defer-warnings (override &optional flags)
    532   (%istruct 'deferred-warnings (unless override *outstanding-deferred-warnings*) nil nil flags))
     530(defun call-with-compilation-unit (thunk &key override)
     531  (let* ((*outstanding-deferred-warnings* (%defer-warnings override)))
     532    (multiple-value-prog1 (funcall thunk)
     533      (report-deferred-warnings))))
     534
     535(defun %defer-warnings (override &optional flags &aux (parent *outstanding-deferred-warnings*))
     536  (%istruct 'deferred-warnings
     537            (unless override parent)
     538            nil
     539            (if (or override (not parent))
     540              (make-hash-table :test #'eq)
     541              (deferred-warnings.defs parent))
     542            flags))
    533543
    534544(defun report-deferred-warnings ()
    535545  (let* ((current *outstanding-deferred-warnings*)
    536546         (parent (deferred-warnings.parent current))
    537          (defs (deferred-warnings.defs current))
    538547         (warnings (deferred-warnings.warnings current))
    539548         (any nil)
     
    541550    (if parent
    542551      (setf (deferred-warnings.warnings parent) (append warnings (deferred-warnings.warnings parent))
    543             (deferred-warnings.defs parent) (append defs (deferred-warnings.defs parent))
    544552            parent t)
    545553      (let* ((file nil)
     554             (defs (deferred-warnings.defs current))
    546555             (init t))
    547556        (flet ((signal-warning (w)
     
    553562                   (def nil))
    554563              (when (if (typep w 'undefined-function-reference)
    555                       (not (setq def (or (assq wfname defs)
     564                      (not (setq def (or (gethash wfname defs)
    556565                                         (let* ((global (fboundp wfname)))
    557566                                           (if (typep global 'function)
     
    561570              (if (or (typep def 'function)
    562571                      (and (consp def)
    563                            (consp (cdr def))
    564                            (consp (cadr def))
    565                            (caadr def)))
     572                           (def-info.lfbits (cdr def))))
    566573                (when (cdr args)
    567574                  (destructuring-bind (arglist spread-p)
     
    579586                                (compiler-warning-stream-position w))
    580587                          (signal-warning w2))))))
    581                 (if (or (and (consp def)
    582                              (consp (cdr def))
    583                              (consp (cadr def))
    584                              (eq (cdadr def) 'macro))
    585                         (typep def 'simple-vector))
     588                (if (def-info.macro-p (cdr def))
    586589                  (let* ((w2 (make-condition
    587590                              'macro-used-before-definition
  • trunk/source/level-1/x86-trap-support.lisp

    r10898 r10942  
    275275(defun (setf indexed-gpr-macptr) (new xp igpr)
    276276  (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))) new))
    277 (defun indexed-gpr-macptr (xp igpr)
    278   (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))))
    279277(defun encoded-gpr-macptr (xp gpr)
    280278  (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
Note: See TracChangeset for help on using the changeset viewer.