Changeset 11502

Timestamp:

Dec 11, 2008, 5:13:47 PM (12 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:

• level-1/l1-readloop.lisp (modified) (1 diff)
• level-1/sysutils.lisp (modified) (2 diffs)
• lib/nfcomp.lisp (modified) (3 diffs)

branches/working-0711/ccl/level-1/l1-readloop.lisp

@@ -500 +500 @@
         (if already
           (setf (%cdr already) (combine-function-infos name (%cdr already) info))
-          (let ((new (cons name info)))
-            (if (listp defs)
-              (setf (defenv.defined definition-env) (cons new defs))
-              (setf (gethash name defs) new))))
+          (let ((outer (loop for defer = (cdr (defenv.type definition-env))
+                               then (deferred-warnings.parent defer)
+                             while (typep defer 'deferred-warnings)
+                             thereis (gethash name (deferred-warnings.defs defer)))))
+            (when outer
+              (setq info (combine-function-infos name (%cdr outer) info)))
+            (let ((new (cons name info)))
+              (if (listp defs)
+                (setf (defenv.defined definition-env) (cons new defs))
+                (setf (gethash name defs) new)))))
         info))))
 

branches/working-0711/ccl/level-1/sysutils.lisp

@@ -537 +537 @@
             (unless override parent)
             nil
-            (if (or override (not parent))
-              (make-hash-table :test #'eq)
-              (deferred-warnings.defs parent))
+            (make-hash-table :test #'eq)
             flags))
 
@@ -546 +544 @@
          (parent (deferred-warnings.parent current))
          (warnings (deferred-warnings.warnings current))
+         (defs (deferred-warnings.defs current))
          (any nil)
          (harsh nil))
     (if parent
-      (setf (deferred-warnings.warnings parent) (append warnings (deferred-warnings.warnings parent))
-            parent t)
+      (let ((parent-defs (deferred-warnings.defs parent))
+            (parent-warnings (deferred-warnings.warnings parent)))
+        (maphash (lambda (key val) (setf (gethash key parent-defs) val)) defs)
+        (setf (deferred-warnings.warnings parent) (append warnings parent-warnings)
+              parent t))
       (let* ((file nil)
-             (defs (deferred-warnings.defs current))
              (init t))
         (flet ((signal-warning (w)

branches/working-0711/ccl/lib/nfcomp.lisp

@@ -151 +151 @@
       (warn "Unknown :TARGET : ~S.  Reverting to ~s ..." target *fasl-target*)
       (setq target *fasl-target*  backend *target-backend*))
-    (loop
-        (restart-case
-         (return (%compile-file src output-file verbose print load features
-                                save-local-symbols save-doc-strings save-definitions
-                                save-source-locations break-on-program-errors
-                                force backend external-format
-                                compile-file-original-truename compile-file-original-buffer-offset))
-         (retry-compile-file ()
-                             :report (lambda (stream) (format stream "Retry compiling ~s" src))
-                             nil)
-         (skip-compile-file ()
-                            :report (lambda (stream) (format stream "Skip compiling ~s" src))
-                            (return))))))
+    (multiple-value-bind (output-file truename warnings-p serious-p)
+        (loop
+          (restart-case
+              (return (%compile-file src output-file verbose print features
+                                     save-local-symbols save-doc-strings save-definitions
+                                     save-source-locations break-on-program-errors
+                                     force backend external-format
+                                     compile-file-original-truename compile-file-original-buffer-offset))
+            (retry-compile-file ()
+              :report (lambda (stream) (format stream "Retry compiling ~s" src))
+              nil)
+            (skip-compile-file ()
+              :report (lambda (stream)
+                        (if load
+                          (format stream "Skip compiling and loading ~s" src)
+                          (format stream "Skip compiling ~s" src)))
+              (return-from compile-file))))
+      (when load (load output-file :verbose (or verbose *load-verbose*)))
+      (values truename warnings-p serious-p))))
+
 
 (defvar *fasl-compile-time-env* nil)
 
-(defun %compile-file (src output-file verbose print load features
+(defun %compile-file (src output-file verbose print features
                           save-local-symbols save-doc-strings save-definitions
                           save-source-locations break-on-program-errors
                           force target-backend external-format
-                          compile-file-original-truename compile-file-original-buffer-offset
-                          &aux orig-src)
-  (setq orig-src (merge-pathnames src))
-  (let* ((output-default-type (backend-target-fasl-pathname target-backend)))
+                          compile-file-original-truename compile-file-original-buffer-offset)
+  (let* ((orig-src (merge-pathnames src))
+         (output-default-type (backend-target-fasl-pathname target-backend))
+         (*fasl-non-style-warnings-signalled-p* nil)
+         (*fasl-warnings-signalled-p* nil))
     (setq src (fcomp-find-file orig-src))
     (let* ((newtype (pathname-type src)))
@@ -180 +188 @@
         (setq orig-src (merge-pathnames orig-src (make-pathname :type newtype :defaults nil)))))
     (setq output-file (merge-pathnames
-                       (if output-file ; full-pathname in case output-file is relative
+                       (if output-file  ; full-pathname in case output-file is relative
                          (full-pathname (merge-pathnames output-file output-default-type) :no-error nil) 
                          output-default-type)
@@ -188 +196 @@
     (when (physical-pathname-p orig-src) ; only back-translate to things likely to exist at load time
       (setq orig-src (back-translate-pathname orig-src '("home" "ccl"))))
-    (let* ((*fasl-non-style-warnings-signalled-p* nil)
-           (*fasl-warnings-signalled-p* nil))
-      (when (and (not force)
-                 (probe-file output-file)
-                 (not (fasl-file-p output-file)))
-        (unless (y-or-n-p
-                 (format nil
-                         "Compile destination ~S is not ~A file!  Overwrite it?"
-                         output-file (pathname-type
-                                      (backend-target-fasl-pathname
-                                       *target-backend*))))
-        (return-from %compile-file nil)))
-      (let* ((*features* (append (if (listp features) features (list features)) (setup-target-features target-backend *features*)))
-             (*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ...
-             (*fasl-save-local-symbols* save-local-symbols)
-             (*fasl-save-source-locations* save-source-locations)
-             (*fasl-save-doc-strings* save-doc-strings)
-             (*fasl-save-definitions* save-definitions)
-             (*fasl-break-on-program-errors* break-on-program-errors)
-             (*fcomp-warnings-header* nil)
-             (*compile-file-pathname* orig-src)
-             (*compile-file-truename* (truename src))
-             (*compile-file-original-truename* compile-file-original-truename)
-             (*compile-file-original-buffer-offset* compile-file-original-buffer-offset)
-             (*package* *package*)
-             (*readtable* *readtable*)
-             (*compile-print* print)
-             (*compile-verbose* verbose)
-             (*fasl-target* (backend-name target-backend))
-             (*fasl-backend* target-backend)
-             (*fasl-target-big-endian* (arch::target-big-endian
-                                        (backend-target-arch target-backend)))
-             (*target-ftd* (backend-target-foreign-type-data target-backend))
-             (defenv (new-definition-environment))
-             (lexenv (new-lexical-environment defenv))
-             (*fasl-compile-time-env* (new-lexical-environment (new-definition-environment)))
-             (*fcomp-external-format* external-format))
-        (let ((forms nil))
-          (let* ((*outstanding-deferred-warnings* (%defer-warnings nil)))
-            (rplacd (defenv.type defenv) *outstanding-deferred-warnings*)
-            (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*))
-
-            (setq forms (fcomp-file src orig-src lexenv))
-
-            (setf (deferred-warnings.warnings *outstanding-deferred-warnings*) 
-                  (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*)))
-            (when *compile-verbose* (fresh-line))
-            (multiple-value-bind (any harsh) (report-deferred-warnings)
-              (setq *fasl-warnings-signalled-p* (or *fasl-warnings-signalled-p* any)
-                    *fasl-non-style-warnings-signalled-p* (if (eq harsh :very) :very
-                                                              (or *fasl-non-style-warnings-signalled-p* harsh)))))
-          (when (and *fasl-break-on-program-errors* (eq *fasl-non-style-warnings-signalled-p* :very))
-            (cerror "create the output file despite the errors"
-                    "Serious errors encountered during compilation of ~s"
-                    src))
-          (fasl-scan-forms-and-dump-file forms output-file lexenv)))
-      (when load (load output-file :verbose (or verbose *load-verbose*)))
-      (values (truename (pathname output-file)) 
+    (when (and (not force)
+               (probe-file output-file)
+               (not (fasl-file-p output-file)))
+      (cerror "overwrite it anyway"
+              "Compile destination ~S is not a ~A file!"
+              output-file (pathname-type
+                           (backend-target-fasl-pathname
+                            *target-backend*))))
+    (let* ((*features* (append (if (listp features) features (list features)) (setup-target-features target-backend *features*)))
+           (*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ...
+           (*fasl-save-local-symbols* save-local-symbols)
+           (*fasl-save-source-locations* save-source-locations)
+           (*fasl-save-doc-strings* save-doc-strings)
+           (*fasl-save-definitions* save-definitions)
+           (*fasl-break-on-program-errors* break-on-program-errors)
+           (*fcomp-warnings-header* nil)
+           (*compile-file-pathname* orig-src)
+           (*compile-file-truename* (truename src))
+           (*compile-file-original-truename* compile-file-original-truename)
+           (*compile-file-original-buffer-offset* compile-file-original-buffer-offset)
+           (*package* *package*)
+           (*readtable* *readtable*)
+           (*compile-print* print)
+           (*compile-verbose* verbose)
+           (*fasl-target* (backend-name target-backend))
+           (*fasl-backend* target-backend)
+           (*fasl-target-big-endian* (arch::target-big-endian
+                                      (backend-target-arch target-backend)))
+           (*target-ftd* (backend-target-foreign-type-data target-backend))
+           (defenv (new-definition-environment))
+           (lexenv (new-lexical-environment defenv))
+           (*fasl-compile-time-env* (new-lexical-environment (new-definition-environment)))
+           (*fcomp-external-format* external-format)
+           (forms nil))
+      (let* ((*outstanding-deferred-warnings* (%defer-warnings nil)))
+        (rplacd (defenv.type defenv) *outstanding-deferred-warnings*)
+        (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*))
+
+        (setq forms (fcomp-file src orig-src lexenv))
+
+        (setf (deferred-warnings.warnings *outstanding-deferred-warnings*) 
+              (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*)))
+        (when *compile-verbose* (fresh-line))
+        (multiple-value-bind (any harsh) (report-deferred-warnings)
+          (setq *fasl-warnings-signalled-p* (or *fasl-warnings-signalled-p* any)
+                *fasl-non-style-warnings-signalled-p* (if (eq harsh :very) :very
+                                                        (or *fasl-non-style-warnings-signalled-p* harsh)))))
+      (when (and *fasl-break-on-program-errors* (eq *fasl-non-style-warnings-signalled-p* :very))
+        (cerror "create the output file despite the errors"
+                "Serious errors encountered during compilation of ~s"
+                src))
+      (fasl-scan-forms-and-dump-file forms output-file lexenv)
+      (values output-file
+              (truename (pathname output-file)) 
               *fasl-warnings-signalled-p* 
               (and *fasl-non-style-warnings-signalled-p* t)))))