/[cmucl]/src/tools/config.lisp
ViewVC logotype

Contents of /src/tools/config.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7.12.2 - (show annotations)
Mon Dec 19 01:10:25 2005 UTC (8 years, 4 months ago) by rtoy
Branch: ppc_gencgc_branch
CVS Tags: ppc_gencgc_snap_2006-01-06, ppc_gencgc_snap_2005-12-17
Changes since 1.7.12.1: +0 -0 lines
Merge code from main branch of 2005-12-17 to ppc gencgc branch.  Still
doesn't work of course.
1 ;;; -*- Mode: Lisp; Package: System -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/tools/config.lisp,v 1.7.12.2 2005/12/19 01:10:25 rtoy Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Utility to load subsystems and save a new core.
15 ;;;
16 (in-package "CL-USER")
17
18
19 (block abort
20 (let ((output-file #p"library:lisp.core")
21 (load-gray-streams t)
22 (load-clm t)
23 (load-clx t)
24 (load-hemlock t)
25 (other ()))
26 (loop
27 (fresh-line)
28 (format t " 1: specify result file (currently ~S)~%"
29 (namestring output-file))
30 (format t " 2: toggle loading of the Gray Stream library, currently ~
31 ~:[dis~;en~]abled.~%"
32 load-gray-streams)
33 (format t " 3: toggle loading of the CLX X library, currently ~
34 ~:[dis~;en~]abled.~%"
35 load-clx)
36 (format t " 4: toggle loading of Motif and the graphical debugger, ~
37 currently ~:[dis~;en~]abled.~
38 ~:[~% (would force loading of CLX.)~;~]~%"
39 load-clm load-clx)
40 (format t " 5: toggle loading the Hemlock editor, currently ~
41 ~:[dis~;en~]abled.~
42 ~:[~% (would force loading of CLX.)~;~]~%"
43 load-hemlock load-clx)
44 (format t " 6: specify some site-specific file to load.~@
45 ~@[ Current files:~%~{ ~S~%~}~]"
46 (mapcar #'namestring other))
47 (format t " 7: configure according to current options.~%")
48 (format t " 8: abort the configuration process.~%")
49 (format t "~%Option number: ")
50 (force-output)
51 (flet ((file-prompt (prompt)
52 (format t prompt)
53 (force-output)
54 (pathname (string-trim " " (read-line)))))
55 (let ((res (ignore-errors (read-from-string (read-line)))))
56 (case res
57 (1
58 (setq output-file (file-prompt "Result core file name: ")))
59 (2
60 (setq load-gray-streams (not load-gray-streams)))
61 (3
62 (unless (setq load-clx (not load-clx))
63 (setq load-hemlock nil)))
64 (4
65 (when (setq load-clm (not load-clm))
66 (setq load-clx t)))
67 (5
68 (when (setq load-hemlock (not load-hemlock))
69 (setq load-clx t)))
70 (6
71 (setq other
72 (append other
73 (list (file-prompt "File(s) to load ~
74 (can have wildcards): ")))))
75 (7 (return))
76 (8
77 (format t "~%Aborted.~%")
78 (return-from abort))))))
79
80 (gc-off)
81 (when load-gray-streams
82 (require :gray-streams))
83 (when load-clx
84 (require :clx))
85 (when load-clm
86 (require :clm))
87 (when load-hemlock
88 (require :hemlock))
89 (dolist (f other) (load f))
90
91 (setq *info-environment*
92 (list* (make-info-environment :name "Working")
93 (compact-info-environment (first *info-environment*)
94 :name "Auxiliary")
95 (rest *info-environment*)))
96
97 (when (probe-file output-file)
98 (multiple-value-bind
99 (ignore old new)
100 (rename-file output-file
101 (concatenate 'string (namestring output-file)
102 ".BAK"))
103 (declare (ignore ignore))
104 (format t "~&Saved ~S as ~S.~%" (namestring old) (namestring new))))
105
106 ;;
107 ;; Enable the garbage collector. But first fake it into thinking that
108 ;; we don't need to garbage collect. The save-lisp is going to call
109 ;; purify so any garbage will be collected then.
110 (setf lisp::*need-to-collect-garbage* nil)
111 (gc-on)
112 ;;
113 ;; Save the lisp.
114 (save-lisp output-file)))
115
116 (quit)

  ViewVC Help
Powered by ViewVC 1.1.5