/[cmucl]/src/code/save.lisp
ViewVC logotype

Diff of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.51.6.1 by gerd, Wed Sep 3 11:32:07 2003 UTC revision 1.73 by rtoy, Thu Nov 4 14:05:01 2010 UTC
# Line 19  Line 19 
19  (in-package "LISP")  (in-package "LISP")
20    
21  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
22    (intl:textdomain "cmucl")
23    
24  (export '(print-herald *herald-items* save-lisp *before-save-initializations*  (export '(print-herald *herald-items* save-lisp *before-save-initializations*
25            *after-save-initializations* *environment-list* *editor-lisp-p*))            *after-save-initializations* *environment-list* *editor-lisp-p*))
26  (in-package "LISP")  (in-package "LISP")
# Line 36  Line 38 
38  (defvar *environment-list* nil  (defvar *environment-list* nil
39    "An alist mapping environment variables (as keywords) to either values")    "An alist mapping environment variables (as keywords) to either values")
40    
41    (defvar *environment-list-initialized* nil
42      "Non-NIL if environment-init has been called")
43    
44  (defvar *editor-lisp-p* nil  (defvar *editor-lisp-p* nil
45    "This is true if and only if the lisp was started with the -edit switch.")    "This is true if and only if the lisp was started with the -edit switch.")
46    
# Line 44  Line 49 
49  ;;; Filled in by the startup code.  ;;; Filled in by the startup code.
50  (defvar lisp-environment-list)  (defvar lisp-environment-list)
51  (defvar *cmucl-lib*)            ; Essentially the envvar CMUCLLIB, if available  (defvar *cmucl-lib*)            ; Essentially the envvar CMUCLLIB, if available
52    
53    #+:executable
54    ;; A dumped executable image won't have any reasonable default
55    ;; library: search list.  Save the one from when it was dumped.
56    (defvar *old-cmucl-library-search-list*)
57    
58  (defvar *cmucl-core-path*)      ; Path to where the Lisp core file was found.  (defvar *cmucl-core-path*)      ; Path to where the Lisp core file was found.
59    
60  ;;; Filled in by the save code.  ;;; Filled in by the save code.
# Line 99  Line 110 
110              (list (default-directory))))              (list (default-directory))))
111    
112    (setf (search-list "library:")    (setf (search-list "library:")
113          (if (boundp '*cmucl-lib*)          (if (and (boundp '*cmucl-lib*)
114                     #+:executable
115                     (not (boundp '*old-cmucl-library-search-list*)))
116              (parse-unix-search-path *cmucl-lib*)              (parse-unix-search-path *cmucl-lib*)
117              '("/usr/local/lib/cmucl/lib/")))              (or
118    (setf (search-list "modules:") '("library:subsystems/")))               #+:executable
119                 *old-cmucl-library-search-list*
120                 '("/usr/local/lib/cmucl/lib/"))))
121      (setf (search-list "modules:")
122            '("library:contrib/" "library:subsystems/" "target:contrib/"))
123      (setf (search-list "ld-library-path:")
124            (parse-unix-search-list :ld_library_path))
125      (setf (search-list "ext-formats:")
126            '("library:ext-formats/"
127              "target:i18n/"
128              "target:pcl/simple-streams/external-formats/"))
129      (setq *environment-list-initialized* t))
130    
131    
132  ;;;; SAVE-LISP itself.  ;;;; SAVE-LISP itself.
133    
134  (alien:def-alien-routine "save" (alien:boolean)  (alien:def-alien-routine "save" (alien:boolean)
135    (file c-call:c-string)    (file c-call:c-string)
136    (initial-function (alien:unsigned #.vm:word-bits)))    (initial-function (alien:unsigned #.vm:word-bits))
137      (sse2-mode c-call:int))
138    
139    #+:executable
140  (alien:def-alien-routine "save_executable" (alien:boolean)  (alien:def-alien-routine "save_executable" (alien:boolean)
141    (file c-call:c-string)    (file c-call:c-string)
142    (initial-function (alien:unsigned #.vm:word-bits)))    (initial-function (alien:unsigned #.vm:word-bits)))
143    
144  (defun save-lisp (core-file-name &key  (defun save-lisp (core-file-name &key
145                    (purify t)                                   (purify t)
146                    (root-structures ())                                   (root-structures ())
147                    (environment-name "Auxiliary")                                   (environment-name "Auxiliary")
148                    (init-function #'%top-level)                                   (init-function #'%top-level)
149                    (load-init-file t)                                   (load-init-file t)
150                    (site-init "library:site-init")                                   (site-init "library:site-init")
151                    (print-herald t)                                   (print-herald t)
152                    (process-command-line t)                                   (process-command-line t)
153                    (executable nil)                                    #+:executable
154                    (batch-mode nil))                                   (executable nil)
155                                     (batch-mode nil))
156    "Saves a CMU Common Lisp core image in the file of the specified name.  The    "Saves a CMU Common Lisp core image in the file of the specified name.  The
157    following keywords are defined:    following keywords are defined:
158    
# Line 151  Line 177 
177    read-eval-print loop.  If the function returns the lisp will exit.    read-eval-print loop.  If the function returns the lisp will exit.
178    
179    :load-init-file    :load-init-file
180        If true, then look for an init.lisp or init.fasl file when the core        If true, then look for an init file when the core file is resumed.
181    file is resumed.    Look for home:init first and then home:.cmucl-init.  No error if
182      there is no init file.
183    
184    :site-init    :site-init
185        If true, then the name of the site init file to load.  The default is        If true, then the name of the site init file to load.  The default is
186        library:site-init.  No error if this does not exist.    library:site-init.  No error if this does not exist.
187    
188    :print-herald    :print-herald
189        If true (the default), print out the lisp system herald when starting.        If true (the default), print out the lisp system herald when starting.
# Line 169  Line 196 
196    :executable    :executable
197        If nil (the default), save-lisp will save using the traditional        If nil (the default), save-lisp will save using the traditional
198     core-file format.  If true, save-lisp will create an executable     core-file format.  If true, save-lisp will create an executable
199     file that contains the lisp image built in.     file that contains the lisp image built in.
200       (Not all architectures support this yet.)
201    
202    :batch-mode    :batch-mode
203        If nil (the default), then the presence of the -batch command-line        If nil (the default), then the presence of the -batch command-line
# Line 178  Line 206 
206    
207    (unless (probe-file (directory-namestring core-file-name))    (unless (probe-file (directory-namestring core-file-name))
208      (error 'simple-file-error      (error 'simple-file-error
209             :format-control "Directory ~S does not exist"             :format-control (intl:gettext "Directory ~S does not exist")
210             :format-arguments (list (directory-namestring core-file-name))))             :format-arguments (list (directory-namestring core-file-name))))
211    
212    #+mp (mp::shutdown-multi-processing)    #+mp (mp::shutdown-multi-processing)
# Line 186  Line 214 
214      (eval:flush-interpreted-function-cache))      (eval:flush-interpreted-function-cache))
215    (when (fboundp 'cancel-finalization)    (when (fboundp 'cancel-finalization)
216      (cancel-finalization sys:*tty*))      (cancel-finalization sys:*tty*))
217    
218      #+:executable
219      (when executable
220        ;; Only do this when dumping an executable Lisp.  Otherwise
221        ;; worldload will make us lose because it clears the search lists.
222        ;; If we are dumping an executable lisp image, we want to keep
223        ;; track of the library search list across dumps because the
224        ;; normal way for figuring out the library paths from arg[0] is
225        ;; almost guaranteed to be wrong for executables.
226        (setf *old-cmucl-library-search-list* (search-list "library:")))
227    
228    (if purify    (if purify
229        (purify :root-structures root-structures        (purify :root-structures root-structures
230                :environment-name environment-name)                :environment-name environment-name)
# Line 194  Line 233 
233    (setq ext:*batch-mode* (if batch-mode t nil))    (setq ext:*batch-mode* (if batch-mode t nil))
234    (labels    (labels
235        ((%restart-lisp ()        ((%restart-lisp ()
236           (with-simple-restart (abort "Skip remaining initializations.")           (with-simple-restart (abort (intl:gettext "Skip remaining initializations."))
237             (catch 'top-level-catcher             (catch 'top-level-catcher
238               (reinit)               (reinit)
239               (environment-init)               (environment-init)
240               (dolist (f *after-save-initializations*) (funcall f))               (dolist (f *after-save-initializations*) (funcall f))
241                 (intl::setlocale)
242               (when process-command-line               (when process-command-line
243                 (ext::process-command-strings))                 (ext::process-command-strings))
244               (setf *editor-lisp-p* nil)               (setf *editor-lisp-p* nil)
# Line 208  Line 248 
248                                   :test #'(lambda (x y)                                   :test #'(lambda (x y)
249                                             (declare (simple-string x y))                                             (declare (simple-string x y))
250                                             (string-equal x y)))))                                             (string-equal x y)))))
251                   (when (and process-command-line (find-switch "quiet"))
252                     (setq *load-verbose* nil
253                           *compile-verbose* nil
254                           *compile-print* nil
255                           *compile-progress* nil
256                           *require-verbose* nil
257                           *gc-verbose* nil
258                           *herald-items* nil))
259                   (when (and process-command-line
260                              (or (find-switch "help")
261                                  (find-switch "-help")))
262                     ;; Don't load any init files if -help or --help is given
263                     (setf site-init nil)
264                     (setf load-init-file nil))
265                 (when (and site-init                 (when (and site-init
266                            (not (and process-command-line                            (not (and process-command-line
267                                      (find-switch "nositeinit"))))                                      (find-switch "nositeinit"))))
# Line 241  Line 295 
295                      (handler-case                      (handler-case
296                          (%restart-lisp)                          (%restart-lisp)
297                        (error (cond)                        (error (cond)
298                          (format *error-output* "Error in batch processing:~%~A~%"                          (format *error-output* (intl:gettext "Error in batch processing:~%~A~%")
299                                  cond)                                  cond)
300                          (throw '%end-of-the-world 1)))                          (throw '%end-of-the-world 1)))
301                      (%restart-lisp))                      (%restart-lisp))
# Line 254  Line 308 
308      (let ((initial-function (get-lisp-obj-address #'restart-lisp))      (let ((initial-function (get-lisp-obj-address #'restart-lisp))
309            (core-name (unix-namestring core-file-name nil)))            (core-name (unix-namestring core-file-name nil)))
310        (without-gcing        (without-gcing
311         (if executable            #+:executable
312             (save-executable core-name initial-function)          (if executable
313             (save core-name initial-function)))))              (save-executable core-name initial-function)
314    (values))              (save core-name initial-function #+sse2 1 #-sse2 0))
315            #-:executable
316            (save core-name initial-function #+sse2 1 #-sse2 0))))
317      nil)
318    
319    
320    
# Line 277  Line 334 
334        `("CMU Common Lisp "        `("CMU Common Lisp "
335          ,#'(lambda (stream)          ,#'(lambda (stream)
336               (write-string (lisp-implementation-version) stream))               (write-string (lisp-implementation-version) stream))
337          ", running on "          ,#'(lambda (stream)
338                 (write-string (intl:gettext ", running on ") stream))
339          ,#'(lambda (stream) (write-string (machine-instance) stream))          ,#'(lambda (stream) (write-string (machine-instance) stream))
340          terpri          terpri
341          ,#'(lambda (stream)          ,#'(lambda (stream)
# Line 288  Line 346 
346                                    *cmucl-core-dump-time*                                    *cmucl-core-dump-time*
347                                    nil)))                                    nil)))
348                 (when core                 (when core
349                   (write-string "With core: " stream)                   (write-string (intl:gettext "With core: ") stream)
350                   (write-line (namestring core) stream))                   (write-line (namestring core) stream))
351                 (when dump-time                 (when dump-time
352                   (write-string "Dumped on: " stream)                   (write-string (intl:gettext "Dumped on: ") stream)
353                   (ext:format-universal-time stream dump-time :style :iso8601)                   (ext:format-universal-time stream dump-time :style :iso8601)
354                   (write-string " on " stream)                   (write-string (intl:gettext " on ") stream)
355                   (write-line *cmucl-core-dump-host* stream))))                   (write-line *cmucl-core-dump-host* stream))))
356          ))          ))
357    
358  (setf (getf *herald-items* :bugs)  (setf (getf *herald-items* :bugs)
359        '("See <http://www.cons.org/cmucl/> for support information."        `(,#'(lambda (stream)
360                 (write-string (intl:gettext "See <http://www.cons.org/cmucl/> for support information.") stream))
361          terpri          terpri
362          "Loaded subsystems:"))          ,#'(lambda (stream)
363                 (write-string (intl:gettext "Loaded subsystems:") stream))))
364    
365    #+unicode
366    (setf (getf *herald-items* :unicode)
367          `(,#'(lambda (stream)
368                 (write-string _"    Unicode " stream))
369            ,(if (and (boundp 'lisp::*unidata-version*)
370                      (>= (length lisp::*unidata-version*) 11))
371                 (subseq lisp::*unidata-version* 11
372                         (1- (length lisp::*unidata-version*)))
373                 " ")
374            ,#'(lambda (stream)
375                 (write-string _"with Unicode version " stream))
376            ,#'(lambda (stream)
377                 (princ lisp::+unicode-major-version+ stream)
378                 (write-char #\. stream)
379                 (princ lisp::+unicode-minor-version+ stream)
380                 (write-char #\. stream)
381                 (princ lisp::+unicode-update-version+ stream))
382            terpri))
383    
384  ;;; PRINT-HERALD  --  Public  ;;; PRINT-HERALD  --  Public
385  ;;;  ;;;
# Line 322  Line 401 
401            ((or symbol cons)            ((or symbol cons)
402             (funcall (fdefinition thing) stream))             (funcall (fdefinition thing) stream))
403            (t            (t
404             (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing))))             (error (intl:gettext "Unrecognized *HERALD-ITEMS* entry: ~S.") thing))))
405        (fresh-line stream)))        (fresh-line stream)))
406    
407    (values))    (values))
# Line 332  Line 411 
411    
412  (defun assert-user-package ()  (defun assert-user-package ()
413    (unless (eq *package* (find-package "CL-USER"))    (unless (eq *package* (find-package "CL-USER"))
414      (error "Change *PACKAGE* to the USER package and try again.")))      (error (intl:gettext "Change *PACKAGE* to the USER package and try again."))))
415    
416  ;;; MAYBE-BYTE-LOAD  --  Interface  ;;; MAYBE-BYTE-LOAD  --  Interface
417  ;;;  ;;;

Legend:
Removed from v.1.51.6.1  
changed lines
  Added in v.1.73

  ViewVC Help
Powered by ViewVC 1.1.5