Changeset 11502


Ignore:
Timestamp:
Dec 11, 2008, 5:13:47 PM (11 years ago)
Author:
gz
Message:

Defer installing defs until file compilation is done, so can restart
without getting duplicate warnings.

Move the loading in (compile-file :load t) case out of the scope of
the recompile restart.

Signal a continuable error (rather than calling y-or-n-p) in case output file
already exists and isn't a fasl file.

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

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-readloop.lisp

    r11495 r11502  
    500500        (if already
    501501          (setf (%cdr already) (combine-function-infos name (%cdr already) info))
    502           (let ((new (cons name info)))
    503             (if (listp defs)
    504               (setf (defenv.defined definition-env) (cons new defs))
    505               (setf (gethash name defs) new))))
     502          (let ((outer (loop for defer = (cdr (defenv.type definition-env))
     503                               then (deferred-warnings.parent defer)
     504                             while (typep defer 'deferred-warnings)
     505                             thereis (gethash name (deferred-warnings.defs defer)))))
     506            (when outer
     507              (setq info (combine-function-infos name (%cdr outer) info)))
     508            (let ((new (cons name info)))
     509              (if (listp defs)
     510                (setf (defenv.defined definition-env) (cons new defs))
     511                (setf (gethash name defs) new)))))
    506512        info))))
    507513
  • branches/working-0711/ccl/level-1/sysutils.lisp

    r11101 r11502  
    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)
  • branches/working-0711/ccl/lib/nfcomp.lisp

    r11279 r11502  
    151151      (warn "Unknown :TARGET : ~S.  Reverting to ~s ..." target *fasl-target*)
    152152      (setq target *fasl-target*  backend *target-backend*))
    153     (loop
    154         (restart-case
    155          (return (%compile-file src output-file verbose print load features
    156                                 save-local-symbols save-doc-strings save-definitions
    157                                 save-source-locations break-on-program-errors
    158                                 force backend external-format
    159                                 compile-file-original-truename compile-file-original-buffer-offset))
    160          (retry-compile-file ()
    161                              :report (lambda (stream) (format stream "Retry compiling ~s" src))
    162                              nil)
    163          (skip-compile-file ()
    164                             :report (lambda (stream) (format stream "Skip compiling ~s" src))
    165                             (return))))))
     153    (multiple-value-bind (output-file truename warnings-p serious-p)
     154        (loop
     155          (restart-case
     156              (return (%compile-file src output-file verbose print features
     157                                     save-local-symbols save-doc-strings save-definitions
     158                                     save-source-locations break-on-program-errors
     159                                     force backend external-format
     160                                     compile-file-original-truename compile-file-original-buffer-offset))
     161            (retry-compile-file ()
     162              :report (lambda (stream) (format stream "Retry compiling ~s" src))
     163              nil)
     164            (skip-compile-file ()
     165              :report (lambda (stream)
     166                        (if load
     167                          (format stream "Skip compiling and loading ~s" src)
     168                          (format stream "Skip compiling ~s" src)))
     169              (return-from compile-file))))
     170      (when load (load output-file :verbose (or verbose *load-verbose*)))
     171      (values truename warnings-p serious-p))))
     172
    166173
    167174(defvar *fasl-compile-time-env* nil)
    168175
    169 (defun %compile-file (src output-file verbose print load features
     176(defun %compile-file (src output-file verbose print features
    170177                          save-local-symbols save-doc-strings save-definitions
    171178                          save-source-locations break-on-program-errors
    172179                          force target-backend external-format
    173                           compile-file-original-truename compile-file-original-buffer-offset
    174                           &aux orig-src)
    175   (setq orig-src (merge-pathnames src))
    176   (let* ((output-default-type (backend-target-fasl-pathname target-backend)))
     180                          compile-file-original-truename compile-file-original-buffer-offset)
     181  (let* ((orig-src (merge-pathnames src))
     182         (output-default-type (backend-target-fasl-pathname target-backend))
     183         (*fasl-non-style-warnings-signalled-p* nil)
     184         (*fasl-warnings-signalled-p* nil))
    177185    (setq src (fcomp-find-file orig-src))
    178186    (let* ((newtype (pathname-type src)))
     
    180188        (setq orig-src (merge-pathnames orig-src (make-pathname :type newtype :defaults nil)))))
    181189    (setq output-file (merge-pathnames
    182                        (if output-file ; full-pathname in case output-file is relative
     190                       (if output-file  ; full-pathname in case output-file is relative
    183191                         (full-pathname (merge-pathnames output-file output-default-type) :no-error nil)
    184192                         output-default-type)
     
    188196    (when (physical-pathname-p orig-src) ; only back-translate to things likely to exist at load time
    189197      (setq orig-src (back-translate-pathname orig-src '("home" "ccl"))))
    190     (let* ((*fasl-non-style-warnings-signalled-p* nil)
    191            (*fasl-warnings-signalled-p* nil))
    192       (when (and (not force)
    193                  (probe-file output-file)
    194                  (not (fasl-file-p output-file)))
    195         (unless (y-or-n-p
    196                  (format nil
    197                          "Compile destination ~S is not ~A file!  Overwrite it?"
    198                          output-file (pathname-type
    199                                       (backend-target-fasl-pathname
    200                                        *target-backend*))))
    201         (return-from %compile-file nil)))
    202       (let* ((*features* (append (if (listp features) features (list features)) (setup-target-features target-backend *features*)))
    203              (*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ...
    204              (*fasl-save-local-symbols* save-local-symbols)
    205              (*fasl-save-source-locations* save-source-locations)
    206              (*fasl-save-doc-strings* save-doc-strings)
    207              (*fasl-save-definitions* save-definitions)
    208              (*fasl-break-on-program-errors* break-on-program-errors)
    209              (*fcomp-warnings-header* nil)
    210              (*compile-file-pathname* orig-src)
    211              (*compile-file-truename* (truename src))
    212              (*compile-file-original-truename* compile-file-original-truename)
    213              (*compile-file-original-buffer-offset* compile-file-original-buffer-offset)
    214              (*package* *package*)
    215              (*readtable* *readtable*)
    216              (*compile-print* print)
    217              (*compile-verbose* verbose)
    218              (*fasl-target* (backend-name target-backend))
    219              (*fasl-backend* target-backend)
    220              (*fasl-target-big-endian* (arch::target-big-endian
    221                                         (backend-target-arch target-backend)))
    222              (*target-ftd* (backend-target-foreign-type-data target-backend))
    223              (defenv (new-definition-environment))
    224              (lexenv (new-lexical-environment defenv))
    225              (*fasl-compile-time-env* (new-lexical-environment (new-definition-environment)))
    226              (*fcomp-external-format* external-format))
    227         (let ((forms nil))
    228           (let* ((*outstanding-deferred-warnings* (%defer-warnings nil)))
    229             (rplacd (defenv.type defenv) *outstanding-deferred-warnings*)
    230             (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*))
    231 
    232             (setq forms (fcomp-file src orig-src lexenv))
    233 
    234             (setf (deferred-warnings.warnings *outstanding-deferred-warnings*)
    235                   (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*)))
    236             (when *compile-verbose* (fresh-line))
    237             (multiple-value-bind (any harsh) (report-deferred-warnings)
    238               (setq *fasl-warnings-signalled-p* (or *fasl-warnings-signalled-p* any)
    239                     *fasl-non-style-warnings-signalled-p* (if (eq harsh :very) :very
    240                                                               (or *fasl-non-style-warnings-signalled-p* harsh)))))
    241           (when (and *fasl-break-on-program-errors* (eq *fasl-non-style-warnings-signalled-p* :very))
    242             (cerror "create the output file despite the errors"
    243                     "Serious errors encountered during compilation of ~s"
    244                     src))
    245           (fasl-scan-forms-and-dump-file forms output-file lexenv)))
    246       (when load (load output-file :verbose (or verbose *load-verbose*)))
    247       (values (truename (pathname output-file))
     198    (when (and (not force)
     199               (probe-file output-file)
     200               (not (fasl-file-p output-file)))
     201      (cerror "overwrite it anyway"
     202              "Compile destination ~S is not a ~A file!"
     203              output-file (pathname-type
     204                           (backend-target-fasl-pathname
     205                            *target-backend*))))
     206    (let* ((*features* (append (if (listp features) features (list features)) (setup-target-features target-backend *features*)))
     207           (*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ...
     208           (*fasl-save-local-symbols* save-local-symbols)
     209           (*fasl-save-source-locations* save-source-locations)
     210           (*fasl-save-doc-strings* save-doc-strings)
     211           (*fasl-save-definitions* save-definitions)
     212           (*fasl-break-on-program-errors* break-on-program-errors)
     213           (*fcomp-warnings-header* nil)
     214           (*compile-file-pathname* orig-src)
     215           (*compile-file-truename* (truename src))
     216           (*compile-file-original-truename* compile-file-original-truename)
     217           (*compile-file-original-buffer-offset* compile-file-original-buffer-offset)
     218           (*package* *package*)
     219           (*readtable* *readtable*)
     220           (*compile-print* print)
     221           (*compile-verbose* verbose)
     222           (*fasl-target* (backend-name target-backend))
     223           (*fasl-backend* target-backend)
     224           (*fasl-target-big-endian* (arch::target-big-endian
     225                                      (backend-target-arch target-backend)))
     226           (*target-ftd* (backend-target-foreign-type-data target-backend))
     227           (defenv (new-definition-environment))
     228           (lexenv (new-lexical-environment defenv))
     229           (*fasl-compile-time-env* (new-lexical-environment (new-definition-environment)))
     230           (*fcomp-external-format* external-format)
     231           (forms nil))
     232      (let* ((*outstanding-deferred-warnings* (%defer-warnings nil)))
     233        (rplacd (defenv.type defenv) *outstanding-deferred-warnings*)
     234        (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*))
     235
     236        (setq forms (fcomp-file src orig-src lexenv))
     237
     238        (setf (deferred-warnings.warnings *outstanding-deferred-warnings*)
     239              (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*)))
     240        (when *compile-verbose* (fresh-line))
     241        (multiple-value-bind (any harsh) (report-deferred-warnings)
     242          (setq *fasl-warnings-signalled-p* (or *fasl-warnings-signalled-p* any)
     243                *fasl-non-style-warnings-signalled-p* (if (eq harsh :very) :very
     244                                                        (or *fasl-non-style-warnings-signalled-p* harsh)))))
     245      (when (and *fasl-break-on-program-errors* (eq *fasl-non-style-warnings-signalled-p* :very))
     246        (cerror "create the output file despite the errors"
     247                "Serious errors encountered during compilation of ~s"
     248                src))
     249      (fasl-scan-forms-and-dump-file forms output-file lexenv)
     250      (values output-file
     251              (truename (pathname output-file))
    248252              *fasl-warnings-signalled-p*
    249253              (and *fasl-non-style-warnings-signalled-p* t)))))
Note: See TracChangeset for help on using the changeset viewer.