File 0001-Handle-environment-initialization-better.p... of Package sbcl

Overview Repositories Revisions Requests Users Attributes Meta

File 0001-Handle-environment-initialization-better.patch of Package sbcl (Revision f3aa57a9614eb24475e08b4725ad0e2b)

Currently displaying revision f3aa57a9614eb24475e08b4725ad0e2b , Show latest

From b7e68df14bbdcee894af620e4168328797be94b9 Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Mon, 29 Apr 2013 21:15:57 +0400
Subject: [PATCH 1/8] Handle environment initialization better.

Don't fail with mysterious errors and memory faults on startup during
initialization of *default-pathname-defaults* when the current
directory contains undecodable characters or is deleted. Similarly
catch decoding errors for things like *runtime-pathname* and
*posix-argv*.
Turn the errors into warnings, and ensure that streams are initialized
and the error messages can be printed.
---
 NEWS                    |  5 ++++
 src/code/cold-init.lisp |  5 ++--
 src/code/common-os.lisp | 63 ++++++++++++++++++++++++++++++++-----------------
 src/code/unix.lisp      |  9 ++++---
 4 files changed, 54 insertions(+), 28 deletions(-)

diff --git a/NEWS b/NEWS
index fc6c9aa..b773b9b 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,9 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
+changes relative to sbcl-1.1.7:
+  * bug fix: handle errors when initializing *default-pathname-defaults*,
+    sb-ext:*runtime-pathname*, sb-ext:*posix-argv* on startup, like character
+    decoding errors, or directories being deleted.
+
 changes in sbcl-1.1.7 relative to sbcl-1.1.6:
   * enhancement: TRACE :PRINT-ALL handles multiple-valued forms.
     (lp#457053)
diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp
index 48a2027..edeb787 100644
--- a/src/code/cold-init.lisp
+++ b/src/code/cold-init.lisp
@@ -349,9 +349,10 @@ process to continue normally."
   (setf sb!alien::*default-c-string-external-format* nil)
   ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS.
   (without-gcing
+    ;; Initialize streams first, so that any errors can be printed later
+    (stream-reinit t)
     (os-cold-init-or-reinit)
     (thread-init-or-reinit)
-    (stream-reinit t)
     #!-(and win32 (not sb-thread))
     (signal-cold-init-or-reinit)
     (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
@@ -408,4 +409,4 @@ process to continue normally."
                    (t
                     (sb!sys:%primitive print (hexstr x)))))))
     (%cold-print x 0))
-  (values))
\ No newline at end of file
+  (values))
diff --git a/src/code/common-os.lisp b/src/code/common-os.lisp
index bf71744..081ccc1 100644
--- a/src/code/common-os.lisp
+++ b/src/code/common-os.lisp
@@ -20,34 +20,55 @@
 (sb!alien:define-alien-variable
  ("saved_runtime_path" *native-saved-runtime-path*) (* char))
 
-;;; if something ever needs to be done differently for one OS, then
+(defmacro init-var-ignoring-errors (variable
+                                    form
+                                    &key default
+                                         explanation
+                                         (condition 'error))
+  `(handler-case
+       (setf ,variable ,form)
+     (,condition (c)
+       (let ((default ,default))
+         (warn "Error initializing ~a~@[ ~a~]:~@
+             ~a
+             ~% Using ~s instead."
+               ',variable
+               ,explanation
+               c
+               default)
+         default))))
+
+;;; If something ever needs to be done differently for one OS, then
 ;;; split out the different part into per-os functions.
 (defun os-cold-init-or-reinit ()
   (/show0 "setting *CORE-STRING*")
-  (setf *core-string*
-        (sb!alien:cast *native-core-string* sb!alien:c-string))
+  (init-var-ignoring-errors
+   *core-string*
+   (sb!alien:cast *native-core-string* sb!alien:c-string)
+   :default "")
   (/show0 "setting *POSIX-ARGV*")
-  (setf sb!ext:*posix-argv*
-        (loop for i from 0
-              for arg = (sb!alien:deref *native-posix-argv* i)
-              until (sb!alien:null-alien arg)
-              collect (sb!alien:cast arg sb!alien:c-string)))
+  (init-var-ignoring-errors
+   sb!ext:*posix-argv*
+   (loop for i from 0
+         for arg = (sb!alien:deref *native-posix-argv* i)
+         until (sb!alien:null-alien arg)
+         collect (sb!alien:cast arg sb!alien:c-string)))
   (/show0 "entering OS-COLD-INIT-OR-REINIT")
   (setf *software-version* nil)
   (/show0 "setting *DEFAULT-PATHNAME-DEFAULTS*")
-  (setf *default-pathname-defaults*
-        ;; (temporary value, so that #'NATIVE-PATHNAME won't blow up when
-        ;; we call it below:)
-        (make-trivial-default-pathname)
-        *default-pathname-defaults*
-        ;; (final value, constructed using #'NATIVE-PATHNAME:)
-        (native-pathname (sb!unix:posix-getcwd/)))
+  ;; Temporary value, so that #'NATIVE-PATHNAME won't blow up when
+  ;; we call it below
+  (setf *default-pathname-defaults* (make-trivial-default-pathname))
+  (init-var-ignoring-errors
+   *default-pathname-defaults* (native-pathname (sb!unix:posix-getcwd/))
+   :default (make-trivial-default-pathname)
+   :explanation "with the current directory")
   (/show0 "setting *CORE-PATHNAME*")
-  (setf *core-pathname*
-        (merge-pathnames (native-pathname *core-string*)))
+  (setf *core-pathname* (merge-pathnames (native-pathname *core-string*)))
   (/show0 "setting *RUNTIME-PATHNAME*")
-  (let ((exe (os-get-runtime-executable-path t))
-        (saved (sb!alien:cast *native-saved-runtime-path* sb!alien:c-string)))
-    (setf *runtime-pathname*
-          (when (or exe saved) (native-pathname (or exe saved)))))
+  (init-var-ignoring-errors
+   *runtime-pathname*
+   (let ((exe (os-get-runtime-executable-path t))
+         (saved (sb!alien:cast *native-saved-runtime-path* sb!alien:c-string)))
+     (when (or exe saved) (native-pathname (or exe saved)))))
   (/show0 "leaving OS-COLD-INIT-OR-REINIT"))
diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index 9572a22..b7a30c8 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -410,11 +410,10 @@ corresponds to NAME, or NIL if there is none."
   ;; helpful, either, as Solaris doesn't export PATH_MAX from
   ;; unistd.h.
   ;;
-  ;; FIXME: The (,stub,) nastiness produces an error message about a
-  ;; comma not inside a backquote. This error has absolutely nothing
-  ;; to do with the actual meaning of the error (and little to do with
-  ;; its location, either).
-  #!-(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32) (,stub,)
+  ;; Signal an error at compile-time, since it's needed for the
+  ;; runtime to start up
+  #!-(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32)
+  #.(error "POSIX-GETCWD is not implemented.")
   #!+(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32)
   (or (newcharstar-string (alien-funcall (extern-alien "getcwd"
                                                        (function (* char)
-- 
1.8.2.1

Places

File 0001-Handle-environment-initialization-better.patch of Package sbcl (Revision f3aa57a9614eb24475e08b4725ad0e2b)

Places