Changeset 12130


Ignore:
Timestamp:
May 26, 2009, 6:39:58 PM (10 years ago)
Author:
gb
Message:

Define KERNEL-PATH: read the (new) kernel global if it's present, use
realpath of (car *command-line-arguments-list*) otherwise. (The kernel
global should be set going forward, but since we're recycling an old
kernel global that may have a non-NIL value it may not be reliable
to use :prepend-kernel until the kernel is rebuilt.)

Try to open the image file (and possibly prepend the kernel to it) in
the calling thread, so that errors that might occur during the process
are signaled while the lisp is still around. Check for errors that
might occur when opening the kernel.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/dumplisp.lisp

    r11983 r12130  
    7575                         )
    7676  (declare (ignore toplevel-function error-handler application-class
    77                    clear-clos-caches init-file impurify
    78                    mode prepend-kernel))
     77                   clear-clos-caches init-file impurify))
    7978  (unless (probe-file (make-pathname :defaults nil
    8079                                     :directory (pathname-directory (translate-logical-pathname filename))))
     
    8685         (cp *current-process*))
    8786    (when (process-verify-quit ip)
    88       (process-interrupt ip
    89                          #'(lambda ()
    90                              (process-exit-application
    91                               *current-process*
    92                               #'(lambda ()
    93                                   (apply #'%save-application-internal
    94                                          filename
    95                                          :purify purify
    96                                          rest)))))
     87      (let* ((fd (open-dumplisp-file filename
     88                                     :mode mode
     89                                     :prepend-kernel prepend-kernel)))
     90        (process-interrupt ip
     91                           #'(lambda ()
     92                               (process-exit-application
     93                                *current-process*
     94                                #'(lambda ()
     95                                    (apply #'%save-application-internal
     96                                           fd
     97                                           :purify purify
     98                                           rest))))))
    9799      (unless (eq cp ip)
    98100        (process-kill cp)))))
    99101
    100 (defun %save-application-internal (filename &key
    101                                             toplevel-function ;????
    102                                             error-handler ; meaningless unless application-class or *application* not lisp-development..
    103                                             application-class
    104                                             (mode #o644)
    105                                             (purify t)
    106                                             (impurify nil)
    107                                             (init-file nil init-file-p)
    108                                             (clear-clos-caches t)
    109                                             (prepend-kernel nil))
     102(defun %save-application-internal (fd &key
     103                                      toplevel-function ;????
     104                                      error-handler ; meaningless unless application-class or *application* not lisp-development..
     105                                      application-class
     106                                      mode
     107                                      (purify t)
     108                                      (impurify nil)
     109                                      (init-file nil init-file-p)
     110                                      (clear-clos-caches t)
     111                                      prepend-kernel)
     112  (declare (ignore mode prepend-kernel))
    110113  (when (and application-class (neq  (class-of *application*)
    111114                                     (if (symbolp application-class)
     
    132135 
    133136  (if clear-clos-caches (clear-clos-caches))
    134   (save-image (let ((fd (open-dumplisp-file filename
    135                                             :mode mode
    136                                             :prepend-kernel prepend-kernel)))
    137                 #'(lambda () (%save-application fd
    138                                                 (logior (if impurify 2 0)
    139                                                         (if purify 1 0)))))
     137  (save-image #'(lambda () (%save-application fd
     138                                              (logior (if impurify 2 0)
     139                                                      (if purify 1 0))))
    140140              toplevel-function))
    141141
     
    206206                (error "I/O error writing to fd ~d" out-fd)))
    207207            (decf len nread))))))
    208    
     208
     209
     210
     211(defun kernel-path ()
     212  (let* ((p (%null-ptr)))
     213    (declare (dynamic-extent p))
     214    (%get-kernel-global-ptr 'kernel-path p)
     215    (if (%null-ptr-p p)
     216      (%realpath (car *command-line-argument-list*))
     217      (let* ((string (%get-utf-8-cstring p)))
     218        #+windows-target (nbackslash-to-forward-slash string)
     219        #+darwin-target (precompose-simple-string string)
     220        #-(or windows-target darwin-target) string))))
     221
     222
    209223(defun open-dumplisp-file (path &key (mode #o666) prepend-kernel)
    210   (let* ((prepend-fd (if prepend-kernel (fd-open
    211                                          (if (eq prepend-kernel t)
    212                                            (car *command-line-argument-list*)
    213                                            (native-translated-namestring
    214                                             (pathname prepend-kernel)))
    215                                          #$O_RDONLY)))
     224  (let* ((prepend-path (if (eq prepend-kernel t)
     225                         (kernel-path)
     226                         (native-translated-namestring
     227                          (pathname prepend-kernel))))
     228         (prepend-fd (if prepend-kernel (fd-open prepend-path #$O_RDONLY)))
    216229         (prepend-len (if (and prepend-fd (>= prepend-fd 0))
    217                         (skip-embedded-image prepend-fd)))
     230                        (skip-embedded-image prepend-fd)
     231                        (signal-file-error prepend-fd prepend-path)))
    218232         (filename (native-translated-namestring path)))
    219233    (when (probe-file filename)
Note: See TracChangeset for help on using the changeset viewer.