Changeset 12249


Ignore:
Timestamp:
Jun 10, 2009, 9:50:40 PM (10 years ago)
Author:
gz
Message:

r11979 r11983 r12130 r12138 r12167 from trunk

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

Legend:

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

    r12223 r12249  
    174174                                           :line-termination :crlf)))
    175175  (let* ((exformat (normalize-external-format t encoding-name)))
     176    #+windows-target (setf (external-format-line-termination external-format)
     177                           :crlf)
    176178    (setf (stream-external-format *stdin*) exformat
    177179          (stream-external-format *stdout*) exformat
  • branches/working-0711/ccl/lib/dumplisp.lisp

    r12213 r12249  
    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)
     
    120123                                   init-file
    121124                                   (application-init-file *application*)))))
    122         (let* ((user-toplevel-function (coerce-to-function toplevel-function)))
     125    (let* ((user-toplevel-function (coerce-to-function toplevel-function)))
    123126      (setq toplevel-function
    124127            (lambda ()
    125               (restore-lisp-pointers)
    126               ;; Shouldn't be necessary post 1.2
    127               ;;(initialize-interactive-streams)
    128128              (process-run-function "toplevel" (lambda ()
    129129                                                 (funcall user-toplevel-function)
     
    135135 
    136136  (if clear-clos-caches (clear-clos-caches))
    137   (save-image (let ((fd (open-dumplisp-file filename
    138                                             :mode mode
    139                                             :prepend-kernel prepend-kernel)))
    140                 #'(lambda () (%save-application fd
    141                                                 (logior (if impurify 2 0)
    142                                                         (if purify 1 0)))))
     137  (save-image #'(lambda () (%save-application fd
     138                                              (logior (if impurify 2 0)
     139                                                      (if purify 1 0))))
    143140              toplevel-function))
    144141
     
    209206                (error "I/O error writing to fd ~d" out-fd)))
    210207            (decf len nread))))))
    211    
     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
    212223(defun open-dumplisp-file (path &key (mode #o666) prepend-kernel)
    213   (let* ((prepend-fd (if prepend-kernel (fd-open
    214                                          (if (eq prepend-kernel t)
    215                                            (car *command-line-argument-list*)
    216                                            (native-translated-namestring
    217                                             (pathname prepend-kernel)))
    218                                          #$O_RDONLY)))
    219          (prepend-len (if (and prepend-fd (>= prepend-fd 0))
    220                         (skip-embedded-image prepend-fd)))
     224  (let* ((prepend-path (if prepend-kernel
     225                         (if (eq prepend-kernel t)
     226                           (kernel-path)
     227                           (native-translated-namestring
     228                          (pathname prepend-kernel)))))
     229         (prepend-fd (if prepend-path (fd-open prepend-path #$O_RDONLY)))
     230         (prepend-len (if prepend-kernel
     231                        (if (and prepend-fd (>= prepend-fd 0))
     232                          (skip-embedded-image prepend-fd)
     233                          (signal-file-error prepend-fd prepend-path))))
    221234         (filename (native-translated-namestring path)))
    222235    (when (probe-file filename)
     
    241254  (setq *interactive-streams-initialized* nil)
    242255  (setq *heap-ivectors* nil)
     256  (setq *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0)))
    243257  (%revive-system-locks)
    244258  (refresh-external-entrypoints)
Note: See TracChangeset for help on using the changeset viewer.