/[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 - (hide 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 ram 1.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 rtoy 1.7.12.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/tools/config.lisp,v 1.7.12.2 2005/12/19 01:10:25 rtoy Exp $")
11 ram 1.1 ;;;
12     ;;; **********************************************************************
13     ;;;
14     ;;; Utility to load subsystems and save a new core.
15     ;;;
16 gerd 1.6 (in-package "CL-USER")
17 ram 1.1
18    
19     (block abort
20     (let ((output-file #p"library:lisp.core")
21 dtc 1.5 (load-gray-streams t)
22 ram 1.4 (load-clm t)
23 ram 1.1 (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 dtc 1.5 (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 wlott 1.2 ~:[dis~;en~]abled.~%"
35 ram 1.1 load-clx)
36 dtc 1.5 (format t " 4: toggle loading of Motif and the graphical debugger, ~
37 ram 1.4 currently ~:[dis~;en~]abled.~
38     ~:[~% (would force loading of CLX.)~;~]~%"
39     load-clm load-clx)
40 dtc 1.5 (format t " 5: toggle loading the Hemlock editor, currently ~
41 wlott 1.2 ~:[dis~;en~]abled.~
42     ~:[~% (would force loading of CLX.)~;~]~%"
43     load-hemlock load-clx)
44 dtc 1.5 (format t " 6: specify some site-specific file to load.~@
45 ram 1.1 ~@[ Current files:~%~{ ~S~%~}~]"
46     (mapcar #'namestring other))
47 dtc 1.5 (format t " 7: configure according to current options.~%")
48     (format t " 8: abort the configuration process.~%")
49 ram 1.1 (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 dtc 1.5 (setq load-gray-streams (not load-gray-streams)))
61     (3
62 ram 1.1 (unless (setq load-clx (not load-clx))
63     (setq load-hemlock nil)))
64 dtc 1.5 (4
65 ram 1.4 (when (setq load-clm (not load-clm))
66     (setq load-clx t)))
67 dtc 1.5 (5
68 ram 1.1 (when (setq load-hemlock (not load-hemlock))
69     (setq load-clx t)))
70 dtc 1.5 (6
71 ram 1.1 (setq other
72     (append other
73     (list (file-prompt "File(s) to load ~
74     (can have wildcards): ")))))
75 dtc 1.5 (7 (return))
76     (8
77 ram 1.1 (format t "~%Aborted.~%")
78     (return-from abort))))))
79    
80     (gc-off)
81 dtc 1.5 (when load-gray-streams
82 rtoy 1.7.12.1 (require :gray-streams))
83 ram 1.1 (when load-clx
84 rtoy 1.7.12.1 (require :clx))
85 ram 1.4 (when load-clm
86 rtoy 1.7.12.1 (require :clm))
87 ram 1.1 (when load-hemlock
88 rtoy 1.7.12.1 (require :hemlock))
89 ram 1.1 (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