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

Contents of /src/code/commandline.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17.14.2 - (hide annotations)
Tue Feb 9 14:56:38 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
CVS Tags: intl-branch-working-2010-02-19-1000, intl-branch-working-2010-02-11-1000, intl-branch-2010-03-18-1300
Changes since 1.17.14.1: +13 -13 lines
Mark translatable strings; update cmucl.pot and ko/cmucl.po
accordingly.
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.17.14.2 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/commandline.lisp,v 1.17.14.2 2010/02/09 14:56:38 rtoy Exp $")
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.17.14.1
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.17.14.2 _N"A list of all the command line arguments after --")
29 rtoy 1.17
30 ram 1.1 (defvar *command-line-switches* ()
31 rtoy 1.17.14.2 _N"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.17.14.2 _N"The string name that was used to invoke this process.")
36 ram 1.1
37     (defvar *command-line-words* ()
38 rtoy 1.17.14.2 _N"A list of words between the utility name and the first switch.")
39 ram 1.1
40     (defvar *command-line-strings* ()
41 rtoy 1.17.14.2 _N"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.17.14.2 _N"An Alist of (\"argument-name\" . demon-function)")
45 ram 1.1
46 phg 1.4 (defvar *batch-mode* nil
47 rtoy 1.17.14.2 _N"When True runs lisp with its input coming from standard-input.
48 phg 1.4 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.17.14.2 _N"Accepts the name of a switch as a string and returns the value of the
132 ram 1.1 switch. If no value was specified, then any following words are returned.
133     If there are no following words, then t is returned. If the switch was not
134     specified, then nil is returned."
135     (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.17.14.2 _N"When set, invoking switch demons complains about illegal switches that have
150 ram 1.1 not been defined with DEFSWITCH.")
151    
152     ;;; This is a list of legal switch names. DEFSWITCH sets this, and
153     ;;; INVOKE-SWITCH-DEMONS makes sure all the switches it sees are on this
154     ;;; list.
155     ;;;
156     (defvar *legal-cmd-line-switches* nil)
157    
158     ;;; INVOKE-SWITCH-DEMONS cdrs down the list of *command-line-switches*. For
159     ;;; each switch, it checks to see if there is a switch demon with the same
160     ;;; name. If there is, then that demon is called as a function on the switch.
161     ;;;
162     (defun invoke-switch-demons (&optional (switches *command-line-switches*)
163     (demons *command-switch-demons*))
164     (dolist (switch switches t)
165     (let* ((name (cmd-switch-name switch))
166     (demon (cdr (assoc name demons :test #'string-equal))))
167     (cond (demon (funcall demon switch))
168     ((or (member name *legal-cmd-line-switches* :test #'string-equal)
169     (not *complain-about-illegal-switches*)))
170 rtoy 1.17.14.2 (t (warn _"~S is an illegal switch" switch)))
171 dtc 1.7 (lisp::finish-standard-output-streams))))
172 ram 1.1
173     (defmacro defswitch (name &optional function)
174 rtoy 1.17.14.2 _N"Associates function with the switch name in *command-switch-demons*. Name
175 ram 1.1 is a simple-string that does not begin with a hyphen, unless the switch name
176     really does begin with one. Function is optional, but defining the switch
177     is necessary to keep invoking switch demons from complaining about illegal
178     switches. This can be inhibited with *complain-about-illegal-switches*."
179     (let ((gname (gensym))
180     (gfunction (gensym)))
181     `(let ((,gname ,name)
182     (,gfunction ,function))
183     (check-type ,gname simple-string)
184 rtoy 1.17.14.2 (check-type ,gfunction (or symbol function) _"a symbol or function")
185 ram 1.1 (push ,gname *legal-cmd-line-switches*)
186     (when ,gfunction
187     (push (cons ,gname ,gfunction) *command-switch-demons*)))))
188    
189    
190     (defun eval-switch-demon (switch)
191 dtc 1.7 (let ((cmds (cmd-switch-arg switch)))
192     (do ((length (length cmds))
193     (start 0))
194     ((>= start length))
195     (multiple-value-bind (form next)
196     (read-from-string cmds nil nil :start start)
197     (eval form)
198     (lisp::finish-standard-output-streams)
199     (setf start next)))))
200 ram 1.1 (defswitch "eval" #'eval-switch-demon)
201    
202     (defun load-switch-demon (switch)
203     (load (cmd-switch-arg switch)))
204     (defswitch "load" #'load-switch-demon)
205    
206     (defun cmd-switch-arg (switch)
207     (or (cmd-switch-value switch)
208     (car (cmd-switch-words switch))
209     (car *command-line-words*)))
210    
211     (defswitch "core")
212     (defswitch "init")
213     (defswitch "noinit")
214 pmai 1.12 (defswitch "nositeinit")
215 ram 1.1 (defswitch "hinit")
216 dtc 1.8 (defswitch "batch")
217 dtc 1.9 (defswitch "dynamic-space-size")
218 toy 1.13 (defswitch "lib")
219 pmai 1.14 (defswitch "quiet")
220 rtoy 1.15 (defswitch "debug-lisp-search")
221 rtoy 1.16 #+x86
222     (defswitch "fpu")

  ViewVC Help
Powered by ViewVC 1.1.5