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

Contents of /src/code/commandline.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.25 - (hide annotations)
Wed Jul 14 13:19:03 2010 UTC (3 years, 9 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, RELEASE_20b, snapshot-2010-11, snapshot-2010-08
Branch point for: RELEASE-20B-BRANCH, sparc-tramp-assem-branch
Changes since 1.24: +3 -2 lines
commandline.lisp:
debug-int.lisp:
load.lisp:

Put the OS- and/or arch-specific items in the correct textdomain.
1 ram 1.1 ;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2 ;;; 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     ;;;
7     (ext:file-comment
8 rtoy 1.25 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/commandline.lisp,v 1.25 2010/07/14 13:19:03 rtoy Rel $")
9 ram 1.2 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Stuff to eat the command line passed to us from the shell.
13     ;;; Written by Bill Chiles.
14     ;;;
15    
16     (in-package "EXTENSIONS")
17 rtoy 1.18
18     (intl:textdomain "cmucl")
19    
20 rtoy 1.17 (export '(*command-line-application-arguments* *command-line-words* *command-line-switches*
21 ram 1.1 *command-switch-demons* *command-line-utility-name*
22 phg 1.4 *command-line-strings* *batch-mode*
23     cmd-switch-string command-line-switch-p
24 ram 1.1 cmd-switch-name cmd-switch-value cmd-switch-words command-line-switch
25     defswitch cmd-switch-arg get-command-line-switch))
26    
27 rtoy 1.17 (defvar *command-line-application-arguments* ()
28 rtoy 1.19 "A list of all the command line arguments after --")
29 rtoy 1.17
30 ram 1.1 (defvar *command-line-switches* ()
31 rtoy 1.19 "A list of cmd-switch's representing the arguments used to invoke
32 ram 1.1 this process.")
33    
34     (defvar *command-line-utility-name* ""
35 rtoy 1.19 "The string name that was used to invoke this process.")
36 ram 1.1
37     (defvar *command-line-words* ()
38 rtoy 1.19 "A list of words between the utility name and the first switch.")
39 ram 1.1
40     (defvar *command-line-strings* ()
41 rtoy 1.19 "A list of strings obtained from the command line that invoked this process.")
42 ram 1.1
43     (defvar *command-switch-demons* ()
44 rtoy 1.19 "An Alist of (\"argument-name\" . demon-function)")
45 ram 1.1
46 phg 1.4 (defvar *batch-mode* nil
47 rtoy 1.19 "When True runs lisp with its input coming from standard-input.
48 rtoy 1.22 If an error is detected returns error code 1, otherwise 0.")
49 ram 1.1
50     (defstruct (command-line-switch (:conc-name cmd-switch-)
51     (:constructor make-cmd-switch
52     (name value words))
53     (:print-function print-command-line-switch))
54     name ;the name of the switch
55     value ;the value of that switch
56     words ;random words dangling between switches assigned to the
57     ;preceeding switch
58     )
59    
60     (defun print-command-line-switch (object stream n)
61     (declare (ignore n))
62     (write-string "#<Command Line Switch " stream)
63     (prin1 (cmd-switch-name object) stream)
64     (let ((value (cmd-switch-value object))
65     (words (cmd-switch-words object)))
66     (when (or value words) (write-string " -- " stream)
67     (when value (prin1 value stream))
68     (when words (prin1 words stream))))
69     (write-string ">" stream))
70    
71    
72    
73     ;;;; Processing the command strings.
74    
75     (defun process-command-strings ()
76     (setq *command-line-words* nil)
77     (setq *command-line-switches* nil)
78     (let ((cmd-strings lisp::lisp-command-line-list)
79     str)
80     (declare (special lisp::lisp-command-line-list))
81     ;; Set some initial variables.
82     ;;
83     (setf *command-line-strings* (copy-list lisp::lisp-command-line-list))
84     (setf *command-line-utility-name* (pop cmd-strings))
85     (setq str (pop cmd-strings))
86     ;; Set initial command line words.
87     ;;
88     (loop
89     (unless str (return nil))
90     (unless (zerop (length (the simple-string str)))
91     (when (char= (schar str 0) #\-)
92     (setq *command-line-words* (reverse *command-line-words*))
93     (return nil))
94     (push str *command-line-words*))
95     (setq str (pop cmd-strings)))
96     ;; Set command line switches.
97     ;;
98     (loop
99     (unless str
100     (return (setf *command-line-switches*
101     (nreverse *command-line-switches*))))
102     (let* ((position (position #\= (the simple-string str) :test #'char=))
103     (switch (subseq (the simple-string str) 1 position))
104     (value (if position
105     (subseq (the simple-string str) (1+ position)
106     (length (the simple-string str))))))
107     (setq str (pop cmd-strings))
108 phg 1.4 ;; Set this switch's words until the next switch.
109 ram 1.1 ;;
110     (let (word-list)
111     (loop
112     (unless str
113     (push (make-cmd-switch switch value (nreverse word-list))
114     *command-line-switches*)
115     (return nil))
116 rtoy 1.17
117 ram 1.1 (unless (zerop (length (the simple-string str)))
118     (when (char= #\- (schar str 0))
119     (push (make-cmd-switch switch value (nreverse word-list))
120     *command-line-switches*)
121 rtoy 1.17 (when (and (= (length str) 2)
122     (char= #\- (schar str 1)))
123     ;; Gather up everything after --, and exit.
124     (setf *command-line-application-arguments* cmd-strings)
125     (setf str nil))
126 ram 1.1 (return nil))
127     (push str word-list))
128     (setq str (pop cmd-strings))))))))
129    
130     (defun get-command-line-switch (sname)
131 rtoy 1.22 "Accepts the name of a switch as a string and returns the value of
132     the switch. If no value was specified, then any following words are
133     returned. If there are no following words, then t is returned. If
134     the switch was not specified, then nil is returned."
135 ram 1.1 (let* ((name (if (char= (schar sname 0) #\-) (subseq sname 1) sname))
136     (switch (find name *command-line-switches*
137     :test #'string-equal
138     :key #'cmd-switch-name)))
139     (when switch
140     (or (cmd-switch-value switch)
141     (cmd-switch-words switch)
142     T))))
143    
144    
145    
146     ;;;; Defining Switches and invoking demons.
147    
148     (defvar *complain-about-illegal-switches* t
149 rtoy 1.22 "When set, invoking switch demons complains about illegal switches
150     that have not been defined with DEFSWITCH.")
151 ram 1.1
152 rtoy 1.21 ;;; This is a list of lists consisting of the legal switch names,
153     ;;; switch description, and argument description. The description and
154     ;;; argument description can be NIL. (Should probably do something
155     ;;; better, but this is good enough for the little bit of processing
156     ;;; that we need.) DEFSWITCH sets this, and INVOKE-SWITCH-DEMONS
157     ;;; makes sure all the switches it sees are on this list.
158 ram 1.1 ;;;
159     (defvar *legal-cmd-line-switches* nil)
160    
161     ;;; INVOKE-SWITCH-DEMONS cdrs down the list of *command-line-switches*. For
162     ;;; each switch, it checks to see if there is a switch demon with the same
163     ;;; name. If there is, then that demon is called as a function on the switch.
164     ;;;
165     (defun invoke-switch-demons (&optional (switches *command-line-switches*)
166     (demons *command-switch-demons*))
167 rtoy 1.21 (flet ((invoke-demon (switch)
168     (let* ((name (cmd-switch-name switch))
169     (demon (cdr (assoc name demons :test #'string-equal))))
170     (cond (demon (funcall demon switch))
171     ((or (member name *legal-cmd-line-switches* :test #'string-equal :key #'car)
172     (not *complain-about-illegal-switches*)))
173     (t (warn (intl:gettext "~S is an illegal switch") switch)))
174     (lisp::finish-standard-output-streams))))
175     ;; We want to process -help (or --help) first, if it's given.
176     ;; Since we're asking for help, we don't want to process any of
177     ;; the other switches.
178     (let ((maybe-help (or (find "help" switches :key #'cmd-switch-name :test #'string-equal)
179     (find "-help" switches :key #'cmd-switch-name :test #'string-equal))))
180     (if maybe-help
181     (invoke-demon maybe-help)
182     (dolist (switch switches t)
183     (invoke-demon switch))))))
184 ram 1.1
185 rtoy 1.21 (defmacro defswitch (name &optional function docstring arg-name)
186 rtoy 1.22 "Associates function with the switch name in
187     *command-switch-demons*. Name is a simple-string that does not
188     begin with a hyphen, unless the switch name really does begin with
189     one. Function is optional, but defining the switch is necessary to
190     keep invoking switch demons from complaining about illegal switches.
191     This can be inhibited with *complain-about-illegal-switches*.
192    
193     The optional arguments, arg-name and docstring, are used by -help to
194     describe the switch. Arg-name is a string naming the argument (if
195     any) for the switch. Docstring describe the switch."
196 ram 1.1 (let ((gname (gensym))
197     (gfunction (gensym)))
198 rtoy 1.23 (when docstring
199     (intl::note-translatable intl::*default-domain* docstring))
200     (when arg-name
201     (intl::note-translatable intl::*default-domain* arg-name))
202 ram 1.1 `(let ((,gname ,name)
203     (,gfunction ,function))
204     (check-type ,gname simple-string)
205 rtoy 1.20 (check-type ,gfunction (or symbol function) (intl:gettext "a symbol or function"))
206 rtoy 1.23 (push (list ,gname ,docstring ,arg-name) *legal-cmd-line-switches*)
207 ram 1.1 (when ,gfunction
208     (push (cons ,gname ,gfunction) *command-switch-demons*)))))
209    
210    
211     (defun eval-switch-demon (switch)
212 dtc 1.7 (let ((cmds (cmd-switch-arg switch)))
213     (do ((length (length cmds))
214     (start 0))
215     ((>= start length))
216     (multiple-value-bind (form next)
217     (read-from-string cmds nil nil :start start)
218     (eval form)
219     (lisp::finish-standard-output-streams)
220     (setf start next)))))
221 rtoy 1.21
222     ;; Docstrings should have lines longer than 72 characters so that we
223     ;; can print out the docstrings nicely on one line for help.
224     ;; | <-- char 72
225     (defswitch "eval" #'eval-switch-demon
226     "Evaluate the specified Lisp expression during the start up
227     sequence. the value of the form will not be printed unless it is
228     wrapped in a form that does output."
229     "expression")
230 ram 1.1
231     (defun load-switch-demon (switch)
232     (load (cmd-switch-arg switch)))
233 rtoy 1.21
234     (defswitch "load" #'load-switch-demon
235     "Loads the specified file into Lisp before entering Lisp's
236     read-eval-print loop."
237     "filename")
238 ram 1.1
239     (defun cmd-switch-arg (switch)
240     (or (cmd-switch-value switch)
241     (car (cmd-switch-words switch))
242     (car *command-line-words*)))
243    
244 rtoy 1.21 (defswitch "core" nil
245     "Specifies the suspended Lisp image ('core' file) to start up"
246     "corefile")
247    
248     (defswitch "init" nil
249     "Specifies the name of a file containing user customizations that is
250     to be loaded each time Lisp starts up (default ~/init or
251     ~/.cmucl-init.lisp). The loader loads any existing compiled binary
252     or the lisp source if none."
253     "filename")
254    
255     (defswitch "noinit" nil
256     "Suppresses loading of the init file and also prevents -edit from
257     loading the Hemlock init file.")
258    
259     (defswitch "nositeinit" nil
260     "Suppresses loading of the site-init site specific initialization
261     file.")
262    
263     (defswitch "hinit" nil
264     "Specifies the name of the Hemlock init file (default ~/hemlock-init
265     or ~/.hemlock-init), which is loaded only when Hemlock is started."
266     "filename")
267    
268     (defswitch "batch" nil
269     "Causes Lisp to run in batch mode where all input is directed from
270     standard-input. A unix return code of 0 is returned upon
271     encountering an EOF, while any unhandled error condition will cause
272     an immediate exit with a return code of 1, instead of entering the
273     debugger.")
274    
275     (defswitch "dynamic-space-size" nil
276     "Specifies the number of megabytes that should be allocated to the
277     heap. If not specified, a platform- specific default is used. The
278     actual maximum allowed heap size is platform-specific."
279     "megabytes")
280    
281     (defswitch "lib" nil
282     "A colon-separated list of directories to be used for the library:
283     search-list."
284     "libpath")
285    
286     (defswitch "quiet" nil
287     "Causes Lisp to start up silently, disabling printing of the herald
288     and causing most unnecessary noise, like GC messages,load messages,
289     etc. to be suppressed.")
290    
291     (defswitch "debug-lisp-search" nil
292     "Enables printing of messages indication how CMUCL is searching for
293     its default core file.")
294    
295 rtoy 1.16 #+x86
296 rtoy 1.25 (intl:with-textdomain ("cmucl" "cmucl-x86-vm")
297 rtoy 1.21 (defswitch "fpu" nil
298     "Specifies what kind of floating-point support should be used on x86
299     systems. If 'x87', Lisp will use the x87 floating-point unit; if
300     'sse2', Lisp uses SSE2 floating-point unit. The default is
301     'auto',which causes Lisp to check to see if SSE2 is available. If
302     so, then SSE2 is used. If the SSE2 core file cannot be found,Lisp
303     will fallback to the x87 core, which can run on any machine."
304 rtoy 1.25 "mode"))
305 rtoy 1.21
306     (defun help-switch-demon (switch)
307     (declare (ignore switch))
308 rtoy 1.24 (format t (intl:gettext "~&Usage: ~A <options>~2%") *command-line-utility-name*)
309 rtoy 1.21 (dolist (s (sort *legal-cmd-line-switches* #'string<
310     :key #'car))
311     (destructuring-bind (name doc arg)
312     s
313 rtoy 1.24 (format t " -~A ~@[~A~]~%" name (if arg (intl:gettext arg)))
314 rtoy 1.21 ;; Poor man's formatting of the help string
315 rtoy 1.23 (with-input-from-string (stream (intl:gettext doc))
316 rtoy 1.21 (loop for line = (read-line stream nil nil)
317     while line
318     do (format t "~8T~A~%" line)))))
319     (ext:quit))
320    
321     (defswitch "help" #'help-switch-demon
322     "Print out the command line options and exit")
323    
324     (defswitch "-help" #'help-switch-demon
325     "Same as -help.")

  ViewVC Help
Powered by ViewVC 1.1.5