/[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.65 by agoncharov, Wed Oct 14 03:42:21 2009 UTC revision 1.66 by rtoy, Fri Mar 19 15:18:59 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")
27    
28  (defvar *before-save-initializations* nil  (defvar *before-save-initializations* nil
29    "This is a list of functions which are called before creating a saved core    _N"This is a list of functions which are called before creating a saved core
30    image.  These functions are executed in the child process which has no ports,    image.  These functions are executed in the child process which has no ports,
31    so they cannot do anything that tries to talk to the outside world.")    so they cannot do anything that tries to talk to the outside world.")
32    
33  (defvar *after-save-initializations* nil  (defvar *after-save-initializations* nil
34    "This is a list of functions which are called when a saved core image starts    _N"This is a list of functions which are called when a saved core image starts
35    up.  The system itself should be initialized at this point, but applications    up.  The system itself should be initialized at this point, but applications
36    might not be.")    might not be.")
37    
38  (defvar *environment-list* nil  (defvar *environment-list* nil
39    "An alist mapping environment variables (as keywords) to either values")    _N"An alist mapping environment variables (as keywords) to either values")
40    
41    (defvar *environment-list-initialized* nil
42      _N"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.")    _N"This is true if and only if the lisp was started with the -edit switch.")
46    
47    
48    
# Line 117  Line 122 
122    (setf (search-list "ext-formats:")    (setf (search-list "ext-formats:")
123          '("library:ext-formats/"          '("library:ext-formats/"
124            "target:i18n/"            "target:i18n/"
125            "target:pcl/simple-streams/external-formats/")))            "target:pcl/simple-streams/external-formats/"))
126      (setq *environment-list-initialized* t))
127    
128    
129  ;;;; SAVE-LISP itself.  ;;;; SAVE-LISP itself.
# Line 144  Line 150 
150                                    #+:executable                                    #+:executable
151                                   (executable nil)                                   (executable nil)
152                                   (batch-mode nil))                                   (batch-mode nil))
153    "Saves a CMU Common Lisp core image in the file of the specified name.  The    _N"Saves a CMU Common Lisp core image in the file of the specified name.  The
154    following keywords are defined:    following keywords are defined:
155    
156    :purify    :purify
# Line 196  Line 202 
202    
203    (unless (probe-file (directory-namestring core-file-name))    (unless (probe-file (directory-namestring core-file-name))
204      (error 'simple-file-error      (error 'simple-file-error
205             :format-control "Directory ~S does not exist"             :format-control _"Directory ~S does not exist"
206             :format-arguments (list (directory-namestring core-file-name))))             :format-arguments (list (directory-namestring core-file-name))))
207    
208    #+mp (mp::shutdown-multi-processing)    #+mp (mp::shutdown-multi-processing)
# Line 223  Line 229 
229    (setq ext:*batch-mode* (if batch-mode t nil))    (setq ext:*batch-mode* (if batch-mode t nil))
230    (labels    (labels
231        ((%restart-lisp ()        ((%restart-lisp ()
232           (with-simple-restart (abort "Skip remaining initializations.")           (with-simple-restart (abort _"Skip remaining initializations.")
233             (catch 'top-level-catcher             (catch 'top-level-catcher
234               (reinit)               (reinit)
235               (environment-init)               (environment-init)
236               (dolist (f *after-save-initializations*) (funcall f))               (dolist (f *after-save-initializations*) (funcall f))
237                 (intl::setlocale)
238               (when process-command-line               (when process-command-line
239                 (ext::process-command-strings))                 (ext::process-command-strings))
240               (setf *editor-lisp-p* nil)               (setf *editor-lisp-p* nil)
# Line 278  Line 285 
285                      (handler-case                      (handler-case
286                          (%restart-lisp)                          (%restart-lisp)
287                        (error (cond)                        (error (cond)
288                          (format *error-output* "Error in batch processing:~%~A~%"                          (format *error-output* _"Error in batch processing:~%~A~%"
289                                  cond)                                  cond)
290                          (throw '%end-of-the-world 1)))                          (throw '%end-of-the-world 1)))
291                      (%restart-lisp))                      (%restart-lisp))
# Line 304  Line 311 
311  ;;;; PRINT-HERALD support.  ;;;; PRINT-HERALD support.
312    
313  (defvar *herald-items* ()  (defvar *herald-items* ()
314    "Determines what PRINT-HERALD prints (the system startup banner.)  This is a    _N"Determines what PRINT-HERALD prints (the system startup banner.)  This is a
315     database which can be augmented by each loaded system.  The format is a     database which can be augmented by each loaded system.  The format is a
316     property list which maps from subsystem names to the banner information for     property list which maps from subsystem names to the banner information for
317     that system.  This list can be manipulated with GETF -- entries are printed     that system.  This list can be manipulated with GETF -- entries are printed
# Line 317  Line 324 
324        `("CMU Common Lisp "        `("CMU Common Lisp "
325          ,#'(lambda (stream)          ,#'(lambda (stream)
326               (write-string (lisp-implementation-version) stream))               (write-string (lisp-implementation-version) stream))
327          ", running on "          ,#'(lambda (stream)
328                 (write-string _", running on " stream))
329          ,#'(lambda (stream) (write-string (machine-instance) stream))          ,#'(lambda (stream) (write-string (machine-instance) stream))
330          terpri          terpri
331          ,#'(lambda (stream)          ,#'(lambda (stream)
# Line 328  Line 336 
336                                    *cmucl-core-dump-time*                                    *cmucl-core-dump-time*
337                                    nil)))                                    nil)))
338                 (when core                 (when core
339                   (write-string "With core: " stream)                   (write-string _"With core: " stream)
340                   (write-line (namestring core) stream))                   (write-line (namestring core) stream))
341                 (when dump-time                 (when dump-time
342                   (write-string "Dumped on: " stream)                   (write-string _"Dumped on: " stream)
343                   (ext:format-universal-time stream dump-time :style :iso8601)                   (ext:format-universal-time stream dump-time :style :iso8601)
344                   (write-string " on " stream)                   (write-string _" on " stream)
345                   (write-line *cmucl-core-dump-host* stream))))                   (write-line *cmucl-core-dump-host* stream))))
346          ))          ))
347    
348  (setf (getf *herald-items* :bugs)  (setf (getf *herald-items* :bugs)
349        '("See <http://www.cons.org/cmucl/> for support information."        `(,#'(lambda (stream)
350                 (write-string _"See <http://www.cons.org/cmucl/> for support information." stream))
351          terpri          terpri
352          "Loaded subsystems:"))          ,#'(lambda (stream)
353                 (write-string _"Loaded subsystems:" stream))))
354    
355  #+unicode  #+unicode
356  (setf (getf *herald-items* :unicode)  (setf (getf *herald-items* :unicode)
357        `("    Unicode "        `(,#'(lambda (stream)
358                 (write-string _"    Unicode " stream))
359          ,(if (and (boundp 'lisp::*unidata-version*)          ,(if (and (boundp 'lisp::*unidata-version*)
360                    (>= (length lisp::*unidata-version*) 11))                    (>= (length lisp::*unidata-version*) 11))
361               (subseq lisp::*unidata-version* 11               (subseq lisp::*unidata-version* 11
362                       (1- (length lisp::*unidata-version*)))                       (1- (length lisp::*unidata-version*)))
363               " ")               " ")
364          "with Unicode version "          ,#'(lambda (stream)
365                 (write-string _"with Unicode version " stream))
366          ,#'(lambda (stream)          ,#'(lambda (stream)
367               (princ lisp::+unicode-major-version+ stream)               (princ lisp::+unicode-major-version+ stream)
368               (write-char #\. stream)               (write-char #\. stream)
# Line 362  Line 374 
374  ;;; PRINT-HERALD  --  Public  ;;; PRINT-HERALD  --  Public
375  ;;;  ;;;
376  (defun print-herald (&optional (stream *standard-output*))  (defun print-herald (&optional (stream *standard-output*))
377    "Print some descriptive information about the Lisp system version and    _N"Print some descriptive information about the Lisp system version and
378     configuration."     configuration."
379    (let ((res ()))    (let ((res ()))
380      (do ((item *herald-items* (cddr item)))      (do ((item *herald-items* (cddr item)))
# Line 379  Line 391 
391            ((or symbol cons)            ((or symbol cons)
392             (funcall (fdefinition thing) stream))             (funcall (fdefinition thing) stream))
393            (t            (t
394             (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing))))             (error _"Unrecognized *HERALD-ITEMS* entry: ~S." thing))))
395        (fresh-line stream)))        (fresh-line stream)))
396    
397    (values))    (values))
# Line 389  Line 401 
401    
402  (defun assert-user-package ()  (defun assert-user-package ()
403    (unless (eq *package* (find-package "CL-USER"))    (unless (eq *package* (find-package "CL-USER"))
404      (error "Change *PACKAGE* to the USER package and try again.")))      (error _"Change *PACKAGE* to the USER package and try again.")))
405    
406  ;;; MAYBE-BYTE-LOAD  --  Interface  ;;; MAYBE-BYTE-LOAD  --  Interface
407  ;;;  ;;;

Legend:
Removed from v.1.65  
changed lines
  Added in v.1.66

  ViewVC Help
Powered by ViewVC 1.1.5