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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Sun Jun 17 02:08:50 1990 UTC (23 years, 10 months ago) by wlott
Changes since 1.1: +119 -90 lines
Initial MIPS version.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; Spice Lisp is currently incomplete and under active development.
7 ;;; If you want to use this code or any part of Spice Lisp, please contact
8 ;;; Scott Fahlman (FAHLMAN@CMUC).
9 ;;; **********************************************************************
10 ;;;
11 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/save.lisp,v 1.1.1.1 1990/06/17 02:08:50 wlott Exp $
12 ;;;
13 ;;; Dump the current lisp image into a core file. All the real work is done
14 ;;; be C.
15 ;;;
16 ;;; Written by William Lott.
17 ;;;
18 ;;;
19 (in-package "LISP")
20
21 (in-package "EXTENSIONS")
22 (export '(print-herald save-lisp *before-save-initializations*
23 *after-save-initializations* *environment-list* *editor-lisp-p*))
24 (in-package "LISP")
25
26 (defvar *before-save-initializations* nil
27 "This is a list of functions which are called before creating a saved core
28 image. These functions are executed in the child process which has no ports,
29 so they cannot do anything that tries to talk to the outside world.")
30
31 (defvar *after-save-initializations* nil
32 "This is a list of functions which are called when a saved core image starts
33 up. The system itself should be initialized at this point, but applications
34 might not be.")
35
36 (defvar *environment-list* nil
37 "An alist mapping environment variables (as keywords) to either values")
38
39 (defvar *editor-lisp-p* nil
40 "This is true if and only if the lisp was started with the -edit switch.")
41
42
43
44 ;;; Filled in by the startup code.
45 (defvar lisp-environment-list)
46
47
48 (def-c-routine "save" (boolean)
49 (file (pointer simple-string)))
50
51
52 (defun save-lisp (core-file-name &key
53 (purify t)
54 (root-structures ())
55 (init-function
56 #'(lambda ()
57 (throw 'top-level-catcher nil)))
58 (load-init-file t)
59 (print-herald t)
60 (process-command-line t))
61 "Saves a CMU Common Lisp core image in the file of the specified name. The
62 following keywords are defined:
63
64 :purify
65 If true, do a purifying GC which moves all dynamically allocated
66 objects into static space so that they stay pure. This takes somewhat
67 longer than the normal GC which is otherwise done, but GC's will done
68 less often and take less time in the resulting core file.
69
70 :root-structures
71 This should be a list of the main entry points in any newly loaded
72 systems. This need not be supplied, but locality will be better if it
73 is. This is meaningless if :purify is Nil.
74
75 :init-function
76 This is a function which is called when the created core file is
77 resumed. The default function simply aborts to the top level
78 read-eval-print loop. If the function returns it will be the value
79 of Save-Lisp.
80
81 :load-init-file
82 If true, then look for an init.lisp or init.fasl file when the core
83 file is resumed.
84
85 :print-herald
86 If true, print out the lisp system herald when starting."
87
88 (declare (ignore purify root-structures))
89 #+nil
90 (if purify
91 (purify :root-structures root-structures)
92 (gc))
93 (unless (save (namestring core-file-name))
94 (dolist (f *before-save-initializations*) (funcall f))
95 (dolist (f *after-save-initializations*) (funcall f))
96 (reinit)
97 (dolist (ele lisp-environment-list)
98 (let ((=pos (position #\= (the simple-string ele))))
99 (when =pos
100 (push (cons (intern (string-upcase (subseq ele 0 =pos))
101 *keyword-package*)
102 (subseq ele (1+ =pos)))
103 *environment-list*))))
104 (setf (search-list "default:") (list (default-directory)))
105 (setf (search-list "path:") (setup-path-search-list))
106 (when process-command-line (ext::process-command-strings))
107 (setf *editor-lisp-p* nil)
108 (macrolet ((find-switch (name)
109 `(find ,name *command-line-switches*
110 :key #'cmd-switch-name
111 :test #'(lambda (x y)
112 (declare (simple-string x y))
113 (string-equal x y)))))
114 (when (and process-command-line (find-switch "edit"))
115 (setf *editor-lisp-p* t))
116 (when (and load-init-file
117 (not (and process-command-line (find-switch "noinit"))))
118 (let* ((cl-switch (find-switch "init"))
119 (name (or (and cl-switch
120 (or (cmd-switch-value cl-switch)
121 (car (cmd-switch-words cl-switch))
122 "init"))
123 "init")))
124 (load (merge-pathnames name (user-homedir-pathname))
125 :if-does-not-exist nil))))
126 (when print-herald
127 (print-herald))
128 (when process-command-line
129 (ext::invoke-switch-demons *command-line-switches*
130 *command-switch-demons*))
131 (funcall init-function)))
132
133
134
135 (defun print-herald ()
136 (write-string "CMU Common Lisp ")
137 (write-line (lisp-implementation-version))
138 (write-string "Hemlock ")
139 (write-string *hemlock-version*)
140 (write-string ", Compiler ")
141 (write-line #+nil compiler-version #-nil "What compiler?")
142 (write-line "Send bug reports and questions to Gripe.")
143 (values))

  ViewVC Help
Powered by ViewVC 1.1.5