From b7e68df14bbdcee894af620e4168328797be94b9 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Mon, 29 Apr 2013 21:15:57 +0400 Subject: [PATCH] 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.7.10.4