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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (hide annotations)
Fri Jan 28 17:22:59 1994 UTC (20 years, 2 months ago) by wlott
Branch: MAIN
Changes since 1.18: +3 -2 lines
Use /usr/local/cmucl instead of /usr/misc/.cmucl on hpux.
1 ram 1.1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.5 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 wlott 1.19 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/save.lisp,v 1.19 1994/01/28 17:22:59 wlott Exp $")
11 ram 1.5 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14 wlott 1.2 ;;; Dump the current lisp image into a core file. All the real work is done
15 ram 1.8 ;;; be C. Also contains various high-level initialization stuff: loading init
16     ;;; files and parsing environment variables.
17 wlott 1.2 ;;;
18     ;;; Written by William Lott.
19 ram 1.1 ;;;
20     ;;;
21     (in-package "LISP")
22    
23     (in-package "EXTENSIONS")
24 ram 1.15 (export '(print-herald *herald-items* save-lisp *before-save-initializations*
25 wlott 1.2 *after-save-initializations* *environment-list* *editor-lisp-p*))
26 ram 1.1 (in-package "LISP")
27    
28 wlott 1.2 (defvar *before-save-initializations* nil
29     "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,
31     so they cannot do anything that tries to talk to the outside world.")
32 ram 1.1
33 wlott 1.2 (defvar *after-save-initializations* nil
34     "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
36     might not be.")
37 ram 1.1
38 wlott 1.2 (defvar *environment-list* nil
39     "An alist mapping environment variables (as keywords) to either values")
40 ram 1.1
41 wlott 1.2 (defvar *editor-lisp-p* nil
42     "This is true if and only if the lisp was started with the -edit switch.")
43    
44    
45    
46     ;;; Filled in by the startup code.
47 ram 1.1 (defvar lisp-environment-list)
48    
49    
50 ram 1.8 ;;; PARSE-UNIX-SEARCH-LIST -- Internal
51     ;;;
52     ;;; Returns a list of the directories that are in the specified Unix
53     ;;; environment variable. Return NIL if the variable is undefined.
54     ;;;
55     (defun parse-unix-search-list (var)
56     (let ((path (cdr (assoc var ext::*environment-list*))))
57     (when path
58     (do* ((i 0 (1+ p))
59     (p (position #\: path :start i)
60     (position #\: path :start i))
61     (pl ()))
62     ((null p)
63     (let ((s (subseq path i)))
64     (if (string= s "")
65     (push "default:" pl)
66     (push (concatenate 'simple-string s "/") pl)))
67     (nreverse pl))
68     (let ((s (subseq path i p)))
69     (if (string= s "")
70     (push "default:" pl)
71     (push (concatenate 'simple-string s "/") pl)))))))
72    
73    
74     ;;; ENVIRONMENT-INIT -- Internal
75     ;;;
76     ;;; Parse the LISP-ENVIRONMENT-LIST into a keyword alist. Set up default
77     ;;; search lists.
78     ;;;
79     (defun environment-init ()
80 ram 1.16 (setq *environment-list* ())
81 ram 1.8 (dolist (ele lisp-environment-list)
82     (let ((=pos (position #\= (the simple-string ele))))
83     (when =pos
84     (push (cons (intern (string-upcase (subseq ele 0 =pos))
85     *keyword-package*)
86     (subseq ele (1+ =pos)))
87     *environment-list*))))
88     (setf (search-list "default:") (list (default-directory)))
89     (setf (search-list "path:") (parse-unix-search-list :path))
90 ram 1.10 (setf (search-list "home:")
91     (or (parse-unix-search-list :home)
92     (list (default-directory))))
93    
94 ram 1.9 (setf (search-list "library:")
95     (or (parse-unix-search-list :cmucllib)
96 wlott 1.19 '(#-hpux "/usr/misc/.cmucl/lib/"
97     #+hpux "/usr/local/cmucl/lib/"))))
98 ram 1.8
99 wlott 1.17
100    
101     ;;;; SAVE-LISP itself.
102    
103     (alien:def-alien-routine "save" (alien:boolean)
104     (file c-call:c-string)
105     (initial-function (alien:unsigned #.vm:word-bits)))
106    
107 wlott 1.2 (defun save-lisp (core-file-name &key
108     (purify t)
109     (root-structures ())
110 wlott 1.3 (constants nil)
111 wlott 1.17 (init-function #'%top-level)
112 wlott 1.2 (load-init-file t)
113 ram 1.8 (site-init "library:site-init")
114 wlott 1.2 (print-herald t)
115     (process-command-line t))
116     "Saves a CMU Common Lisp core image in the file of the specified name. The
117     following keywords are defined:
118    
119     :purify
120 ram 1.18 If true (the default), do a purifying GC which moves all dynamically
121     allocated objects into static space so that they stay pure. This takes
122     somewhat longer than the normal GC which is otherwise done, but GC's will
123     done less often and take less time in the resulting core file.
124 wlott 1.2
125     :root-structures
126 wlott 1.3 :constants
127     These should be a list of the main entry points in any newly loaded
128     systems and a list of any large data structures that will never again
129     be changed. These need not be supplied, but locality and/or GC performance
130     will be better if they are. They are meaningless if :purify is NIL.
131 wlott 1.2
132     :init-function
133 ram 1.18 This is the function that starts running when the created core file is
134 wlott 1.17 resumed. The default function simply invokes the top level
135     read-eval-print loop. If the function returns the lisp will exit.
136 wlott 1.2
137     :load-init-file
138     If true, then look for an init.lisp or init.fasl file when the core
139     file is resumed.
140 ram 1.8
141     :site-init
142     If true, then the name of the site init file to load. The default is
143     library:site-init. No error if this does not exist.
144    
145 wlott 1.2 :print-herald
146 ram 1.18 If true (the default), print out the lisp system herald when starting."
147 ram 1.4
148 ram 1.8 (when (fboundp 'eval:flush-interpreted-function-cache)
149     (eval:flush-interpreted-function-cache))
150 wlott 1.2 (if purify
151 wlott 1.3 (purify :root-structures root-structures :constants constants)
152 wlott 1.2 (gc))
153 wlott 1.17 (flet
154     ((restart-lisp ()
155     (catch '%end-of-the-world
156     (with-simple-restart (abort "Skip remaining initializations.")
157     (catch 'top-level-catcher
158     (reinit)
159     (dolist (f *before-save-initializations*) (funcall f))
160     (dolist (f *after-save-initializations*) (funcall f))
161     (environment-init)
162     (when site-init
163     (load site-init :if-does-not-exist nil :verbose nil))
164     (when process-command-line
165     (ext::process-command-strings))
166     (setf *editor-lisp-p* nil)
167     (macrolet ((find-switch (name)
168     `(find ,name *command-line-switches*
169     :key #'cmd-switch-name
170     :test #'(lambda (x y)
171     (declare (simple-string x y))
172     (string-equal x y)))))
173     (when (and process-command-line (find-switch "edit"))
174     (setf *editor-lisp-p* t))
175     (when (and load-init-file
176     (not (and process-command-line
177     (find-switch "noinit"))))
178     (let* ((cl-switch (find-switch "init"))
179     (name (and cl-switch
180     (or (cmd-switch-value cl-switch)
181     (car (cmd-switch-words
182     cl-switch))))))
183     (if name
184     (load (merge-pathnames name #p"home:")
185     :if-does-not-exist nil)
186     (or (load "home:init" :if-does-not-exist nil)
187     (load "home:.cmucl-init"
188     :if-does-not-exist nil))))))
189     (when process-command-line
190     (ext::invoke-switch-demons *command-line-switches*
191     *command-switch-demons*))
192     (when print-herald
193     (print-herald))))
194     (funcall init-function))
195     (unix:unix-exit 0)))
196     (let ((initial-function (get-lisp-obj-address #'restart-lisp)))
197     (without-gcing
198     (save (unix-namestring core-file-name nil) initial-function))))
199     nil)
200 wlott 1.2
201 wlott 1.17
202    
203     ;;;; PRINT-HERALD support.
204 wlott 1.2
205 ram 1.15 (defvar *herald-items* ()
206     "Determines what PRINT-HERALD prints (the system startup banner.) This is a
207     database which can be augmented by each loaded system. The format is a
208     property list which maps from subsystem names to the banner information for
209     that system. This list can be manipulated with GETF -- entries are printed
210     in, reverse order, so the newest entry is printed last. Usually the system
211     feature keyword is used as the system name. A given banner is a list of
212     strings and functions (or function names). Strings are printed, and
213     functions are called with an output stream argument.")
214    
215     (setf (getf *herald-items* :common-lisp)
216     `("CMU Common Lisp "
217     ,#'(lambda (stream)
218     (write-string (lisp-implementation-version) stream))
219     ", running on "
220     ,#'(lambda (stream) (write-string (machine-instance) stream))))
221    
222     (setf (getf *herald-items* :bugs)
223     '("Send bug reports and questions to cmucl-bugs@cs.cmu.edu."
224     terpri
225     "Loaded subsystems:"))
226    
227     ;;; PRINT-HERALD -- Public
228     ;;;
229     (defun print-herald (&optional (stream *standard-output*))
230     "Print some descriptive information about the Lisp system version and
231     configuration."
232     (let ((res ()))
233     (do ((item *herald-items* (cddr item)))
234     ((null item))
235     (push (second item) res))
236    
237     (fresh-line stream)
238     (dolist (item res)
239     (dolist (thing item)
240     (typecase thing
241     (string
242     (write-string thing stream))
243     (function (funcall thing stream))
244     ((or symbol cons)
245     (funcall (fdefinition thing) stream))
246     (t
247     (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing))))
248     (fresh-line stream)))
249    
250 wlott 1.2 (values))
251    
252    
253     ;;;; Random functions used by worldload.
254    
255     (defun assert-user-package ()
256     (unless (eq *package* (find-package "USER"))
257     (error "Change *PACKAGE* to the USER package and try again.")))

  ViewVC Help
Powered by ViewVC 1.1.5