Changeset 11514


Ignore:
Timestamp:
Dec 12, 2008, 6:15:09 PM (11 years ago)
Author:
gz
Message:

propagate r11502 to trunk

Location:
trunk/source
Files:
3 edited

Legend:

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

    r11040 r11514  
    495495        (if already
    496496          (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))))
     497          (let ((outer (loop for defer = (cdr (defenv.type definition-env))
     498                               then (deferred-warnings.parent defer)
     499                             while (typep defer 'deferred-warnings)
     500                             thereis (gethash name (deferred-warnings.defs defer)))))
     501            (when outer
     502              (setq info (combine-function-infos name (%cdr outer) info)))
     503            (let ((new (cons name info)))
     504              (if (listp defs)
     505                (setf (defenv.defined definition-env) (cons new defs))
     506                (setf (gethash name defs) new)))))
    501507        info))))
    502508
  • trunk/source/level-1/sysutils.lisp

    r10942 r11514  
    537537            (unless override parent)
    538538            nil
    539             (if (or override (not parent))
    540               (make-hash-table :test #'eq)
    541               (deferred-warnings.defs parent))
     539            (make-hash-table :test #'eq)
    542540            flags))
    543541
     
    546544         (parent (deferred-warnings.parent current))
    547545         (warnings (deferred-warnings.warnings current))
     546         (defs (deferred-warnings.defs current))
    548547         (any nil)
    549548         (harsh nil))
    550549    (if parent
    551       (setf (deferred-warnings.warnings parent) (append warnings (deferred-warnings.warnings parent))
    552             parent t)
     550      (let ((parent-defs (deferred-warnings.defs parent))
     551            (parent-warnings (deferred-warnings.warnings parent)))
     552        (maphash (lambda (key val) (setf (gethash key parent-defs) val)) defs)
     553        (setf (deferred-warnings.warnings parent) (append warnings parent-warnings)
     554              parent t))
    553555      (let* ((file nil)
    554              (defs (deferred-warnings.defs current))
    555556             (init t))
    556557        (flet ((signal-warning (w)
  • trunk/source/lib/nfcomp.lisp

    r11420 r11514  
    143143      (warn "Unknown :TARGET : ~S.  Reverting to ~s ..." target *fasl-target*)
    144144      (setq target *fasl-target*  backend *target-backend*))
    145     (loop
    146         (restart-case
    147          (return (%compile-file src output-file verbose print load features
    148                                 save-local-symbols save-doc-strings save-definitions
    149                                 save-source-locations break-on-program-errors
    150                                 force backend external-format
    151                                 compile-file-original-truename compile-file-original-buffer-offset))
    152          (retry-compile-file ()
    153                              :report (lambda (stream) (format stream "Retry compiling ~s" src))
    154                              nil)
    155          (skip-compile-file ()
    156                             :report (lambda (stream) (format stream "Skip compiling ~s" src))
    157                             (return))))))
     145    (multiple-value-bind (output-file truename warnings-p serious-p)
     146        (loop
     147          (restart-case
     148              (return (%compile-file src output-file verbose print features
     149                                     save-local-symbols save-doc-strings save-definitions
     150                                     save-source-locations break-on-program-errors
     151                                     force backend external-format
     152                                     compile-file-original-truename compile-file-original-buffer-offset))
     153            (retry-compile-file ()
     154              :report (lambda (stream) (format stream "Retry compiling ~s" src))
     155              nil)
     156            (skip-compile-file ()
     157              :report (lambda (stream)
     158                        (if load
     159                          (format stream "Skip compiling and loading ~s" src)
     160                          (format stream "Skip compiling ~s" src)))
     161              (return-from compile-file))))
     162      (when load (load output-file :verbose (or verbose *load-verbose*)))
     163      (values truename warnings-p serious-p))))
     164
    158165
    159166(defvar *fasl-compile-time-env* nil)
    160167
    161 (defun %compile-file (src output-file verbose print load features
     168(defun %compile-file (src output-file verbose print features
    162169                          save-local-symbols save-doc-strings save-definitions
    163170                          save-source-locations break-on-program-errors
     
    165172                          compile-file-original-truename compile-file-original-buffer-offset)
    166173  (let* ((orig-src (merge-pathnames src))
    167          (output-default-type (backend-target-fasl-pathname target-backend)))
     174         (output-default-type (backend-target-fasl-pathname target-backend))
     175         (*fasl-non-style-warnings-signalled-p* nil)
     176         (*fasl-warnings-signalled-p* nil))
    168177    (setq src (fcomp-find-file orig-src))
    169178    (let* ((newtype (pathname-type src)))
     
    171180        (setq orig-src (merge-pathnames orig-src (make-pathname :type newtype :defaults nil)))))
    172181    (setq output-file (merge-pathnames
    173                        (if output-file ; full-pathname in case output-file is relative
     182                       (if output-file  ; full-pathname in case output-file is relative
    174183                         (full-pathname (merge-pathnames output-file output-default-type) :no-error nil)
    175184                         output-default-type)
     
    179188    (when (physical-pathname-p orig-src) ; only back-translate to things likely to exist at load time
    180189      (setq orig-src (back-translate-pathname orig-src '("home" "ccl"))))
    181     (let* ((*fasl-non-style-warnings-signalled-p* nil)
    182            (*fasl-warnings-signalled-p* nil))
    183       (when (and (not force)
    184                  (probe-file output-file)
    185                  (not (fasl-file-p output-file)))
    186         (unless (y-or-n-p
    187                  (format nil
    188                          "Compile destination ~S is not ~A file!  Overwrite it?"
    189                          output-file (pathname-type
    190                                       (backend-target-fasl-pathname
    191                                        *target-backend*))))
    192         (return-from %compile-file nil)))
     190    (when (and (not force)
     191               (probe-file output-file)
     192               (not (fasl-file-p output-file)))
     193      (cerror "overwrite it anyway"
     194              "Compile destination ~S is not a ~A file!"
     195              output-file (pathname-type
     196                           (backend-target-fasl-pathname
     197                            *target-backend*))))
    193198      (let* ((*features* (append (if (listp features) features (list features)) (setup-target-features target-backend *features*)))
    194199             (*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ...
     
    213218             (lexenv (new-lexical-environment defenv))
    214219             (*fasl-compile-time-env* (new-lexical-environment (new-definition-environment)))
    215              (*fcomp-external-format* external-format))
    216         (let ((forms nil))
    217           (let* ((*outstanding-deferred-warnings* (%defer-warnings nil)))
    218             (rplacd (defenv.type defenv) *outstanding-deferred-warnings*)
    219             (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*))
    220 
    221             (setq forms (fcomp-file src
    222                                     (or compile-file-original-truename orig-src)
    223                                     compile-file-original-buffer-offset
    224                                     lexenv))
    225 
    226             (setf (deferred-warnings.warnings *outstanding-deferred-warnings*)
    227                   (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*)))
    228             (when *compile-verbose* (fresh-line))
    229             (multiple-value-bind (any harsh) (report-deferred-warnings)
    230               (setq *fasl-warnings-signalled-p* (or *fasl-warnings-signalled-p* any)
    231                     *fasl-non-style-warnings-signalled-p* (if (eq harsh :very) :very
    232                                                               (or *fasl-non-style-warnings-signalled-p* harsh)))))
    233           (when (and *fasl-break-on-program-errors* (eq *fasl-non-style-warnings-signalled-p* :very))
    234             (cerror "create the output file despite the errors"
    235                     "Serious errors encountered during compilation of ~s"
    236                     src))
    237           (fasl-scan-forms-and-dump-file forms output-file lexenv)))
    238       (when load (load output-file :verbose (or verbose *load-verbose*)))
    239       (values (truename (pathname output-file))
     220             (*fcomp-external-format* external-format)
     221             (forms nil))
     222      (let* ((*outstanding-deferred-warnings* (%defer-warnings nil)))
     223        (rplacd (defenv.type defenv) *outstanding-deferred-warnings*)
     224        (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*))
     225
     226        (setq forms (fcomp-file src
     227                                (or compile-file-original-truename orig-src)
     228                                compile-file-original-buffer-offset
     229                                lexenv))
     230
     231        (setf (deferred-warnings.warnings *outstanding-deferred-warnings*)
     232              (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*)))
     233        (when *compile-verbose* (fresh-line))
     234        (multiple-value-bind (any harsh) (report-deferred-warnings)
     235          (setq *fasl-warnings-signalled-p* (or *fasl-warnings-signalled-p* any)
     236                *fasl-non-style-warnings-signalled-p* (if (eq harsh :very) :very
     237                                                        (or *fasl-non-style-warnings-signalled-p* harsh)))))
     238      (when (and *fasl-break-on-program-errors* (eq *fasl-non-style-warnings-signalled-p* :very))
     239        (cerror "create the output file despite the errors"
     240                "Serious errors encountered during compilation of ~s"
     241                src))
     242      (fasl-scan-forms-and-dump-file forms output-file lexenv)
     243      (values output-file
     244              (truename (pathname output-file))
    240245              *fasl-warnings-signalled-p*
    241246              (and *fasl-non-style-warnings-signalled-p* t)))))
Note: See TracChangeset for help on using the changeset viewer.