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

Contents of /src/code/commandline.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Tue Jan 6 01:11:23 2009 UTC (5 years, 3 months ago) by rtoy
Branch: MAIN
CVS Tags: merged-unicode-utf16-extfmt-2009-06-11, unicode-string-buffer-impl-base, unicode-string-buffer-base, amd64-dd-start, release-19f-pre1, intl-2-branch-base, label-2009-03-16, release-19f-base, merge-with-19f, RELEASE_19f, release-20a-base, pre-merge-intl-branch, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, label-2009-03-25, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, portable-clx-import-2009-06-16, intl-branch-base, portable-clx-base, snapshot-2009-08, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04
Branch point for: RELEASE-19F-BRANCH, portable-clx-branch, unicode-string-buffer-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, intl-2-branch
Changes since 1.16: +11 -2 lines
code/commandline.lisp:
o Command line parsing now recognizes "--" and disables any further
  processing by CMUCL itself.  Everything after "--" is placed in the
  new variable EXT:*COMMAND-LINE-APPLICATION-ARGUMENTS*, which is a
  list of strings.

code/exports.lisp:
o Export EXT:*COMMAND-LINE-APPLICATION-ARGUMENTS*.

general-info/release-19f.txt:
o Update.
1 ;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
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 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/commandline.lisp,v 1.17 2009/01/06 01:11:23 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
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 (export '(*command-line-application-arguments* *command-line-words* *command-line-switches*
18 *command-switch-demons* *command-line-utility-name*
19 *command-line-strings* *batch-mode*
20 cmd-switch-string command-line-switch-p
21 cmd-switch-name cmd-switch-value cmd-switch-words command-line-switch
22 defswitch cmd-switch-arg get-command-line-switch))
23
24 (defvar *command-line-application-arguments* ()
25 "A list of all the command line arguments after --")
26
27 (defvar *command-line-switches* ()
28 "A list of cmd-switch's representing the arguments used to invoke
29 this process.")
30
31 (defvar *command-line-utility-name* ""
32 "The string name that was used to invoke this process.")
33
34 (defvar *command-line-words* ()
35 "A list of words between the utility name and the first switch.")
36
37 (defvar *command-line-strings* ()
38 "A list of strings obtained from the command line that invoked this process.")
39
40 (defvar *command-switch-demons* ()
41 "An Alist of (\"argument-name\" . demon-function)")
42
43 (defvar *batch-mode* nil
44 "When True runs lisp with its input coming from standard-input.
45 If an error is detected returns error code 1, otherwise 0.")
46
47 (defstruct (command-line-switch (:conc-name cmd-switch-)
48 (:constructor make-cmd-switch
49 (name value words))
50 (:print-function print-command-line-switch))
51 name ;the name of the switch
52 value ;the value of that switch
53 words ;random words dangling between switches assigned to the
54 ;preceeding switch
55 )
56
57 (defun print-command-line-switch (object stream n)
58 (declare (ignore n))
59 (write-string "#<Command Line Switch " stream)
60 (prin1 (cmd-switch-name object) stream)
61 (let ((value (cmd-switch-value object))
62 (words (cmd-switch-words object)))
63 (when (or value words) (write-string " -- " stream)
64 (when value (prin1 value stream))
65 (when words (prin1 words stream))))
66 (write-string ">" stream))
67
68
69
70 ;;;; Processing the command strings.
71
72 (defun process-command-strings ()
73 (setq *command-line-words* nil)
74 (setq *command-line-switches* nil)
75 (let ((cmd-strings lisp::lisp-command-line-list)
76 str)
77 (declare (special lisp::lisp-command-line-list))
78 ;; Set some initial variables.
79 ;;
80 (setf *command-line-strings* (copy-list lisp::lisp-command-line-list))
81 (setf *command-line-utility-name* (pop cmd-strings))
82 (setq str (pop cmd-strings))
83 ;; Set initial command line words.
84 ;;
85 (loop
86 (unless str (return nil))
87 (unless (zerop (length (the simple-string str)))
88 (when (char= (schar str 0) #\-)
89 (setq *command-line-words* (reverse *command-line-words*))
90 (return nil))
91 (push str *command-line-words*))
92 (setq str (pop cmd-strings)))
93 ;; Set command line switches.
94 ;;
95 (loop
96 (unless str
97 (return (setf *command-line-switches*
98 (nreverse *command-line-switches*))))
99 (let* ((position (position #\= (the simple-string str) :test #'char=))
100 (switch (subseq (the simple-string str) 1 position))
101 (value (if position
102 (subseq (the simple-string str) (1+ position)
103 (length (the simple-string str))))))
104 (setq str (pop cmd-strings))
105 ;; Set this switch's words until the next switch.
106 ;;
107 (let (word-list)
108 (loop
109 (unless str
110 (push (make-cmd-switch switch value (nreverse word-list))
111 *command-line-switches*)
112 (return nil))
113
114 (unless (zerop (length (the simple-string str)))
115 (when (char= #\- (schar str 0))
116 (push (make-cmd-switch switch value (nreverse word-list))
117 *command-line-switches*)
118 (when (and (= (length str) 2)
119 (char= #\- (schar str 1)))
120 ;; Gather up everything after --, and exit.
121 (setf *command-line-application-arguments* cmd-strings)
122 (setf str nil))
123 (return nil))
124 (push str word-list))
125 (setq str (pop cmd-strings))))))))
126
127 (defun get-command-line-switch (sname)
128 "Accepts the name of a switch as a string and returns the value of the
129 switch. If no value was specified, then any following words are returned.
130 If there are no following words, then t is returned. If the switch was not
131 specified, then nil is returned."
132 (let* ((name (if (char= (schar sname 0) #\-) (subseq sname 1) sname))
133 (switch (find name *command-line-switches*
134 :test #'string-equal
135 :key #'cmd-switch-name)))
136 (when switch
137 (or (cmd-switch-value switch)
138 (cmd-switch-words switch)
139 T))))
140
141
142
143 ;;;; Defining Switches and invoking demons.
144
145 (defvar *complain-about-illegal-switches* t
146 "When set, invoking switch demons complains about illegal switches that have
147 not been defined with DEFSWITCH.")
148
149 ;;; This is a list of legal switch names. DEFSWITCH sets this, and
150 ;;; INVOKE-SWITCH-DEMONS makes sure all the switches it sees are on this
151 ;;; list.
152 ;;;
153 (defvar *legal-cmd-line-switches* nil)
154
155 ;;; INVOKE-SWITCH-DEMONS cdrs down the list of *command-line-switches*. For
156 ;;; each switch, it checks to see if there is a switch demon with the same
157 ;;; name. If there is, then that demon is called as a function on the switch.
158 ;;;
159 (defun invoke-switch-demons (&optional (switches *command-line-switches*)
160 (demons *command-switch-demons*))
161 (dolist (switch switches t)
162 (let* ((name (cmd-switch-name switch))
163 (demon (cdr (assoc name demons :test #'string-equal))))
164 (cond (demon (funcall demon switch))
165 ((or (member name *legal-cmd-line-switches* :test #'string-equal)
166 (not *complain-about-illegal-switches*)))
167 (t (warn "~S is an illegal switch" switch)))
168 (lisp::finish-standard-output-streams))))
169
170 (defmacro defswitch (name &optional function)
171 "Associates function with the switch name in *command-switch-demons*. Name
172 is a simple-string that does not begin with a hyphen, unless the switch name
173 really does begin with one. Function is optional, but defining the switch
174 is necessary to keep invoking switch demons from complaining about illegal
175 switches. This can be inhibited with *complain-about-illegal-switches*."
176 (let ((gname (gensym))
177 (gfunction (gensym)))
178 `(let ((,gname ,name)
179 (,gfunction ,function))
180 (check-type ,gname simple-string)
181 (check-type ,gfunction (or symbol function) "a symbol or function")
182 (push ,gname *legal-cmd-line-switches*)
183 (when ,gfunction
184 (push (cons ,gname ,gfunction) *command-switch-demons*)))))
185
186
187 (defun eval-switch-demon (switch)
188 (let ((cmds (cmd-switch-arg switch)))
189 (do ((length (length cmds))
190 (start 0))
191 ((>= start length))
192 (multiple-value-bind (form next)
193 (read-from-string cmds nil nil :start start)
194 (eval form)
195 (lisp::finish-standard-output-streams)
196 (setf start next)))))
197 (defswitch "eval" #'eval-switch-demon)
198
199 (defun load-switch-demon (switch)
200 (load (cmd-switch-arg switch)))
201 (defswitch "load" #'load-switch-demon)
202
203 (defun cmd-switch-arg (switch)
204 (or (cmd-switch-value switch)
205 (car (cmd-switch-words switch))
206 (car *command-line-words*)))
207
208 (defswitch "core")
209 (defswitch "init")
210 (defswitch "noinit")
211 (defswitch "nositeinit")
212 (defswitch "hinit")
213 (defswitch "batch")
214 (defswitch "dynamic-space-size")
215 (defswitch "lib")
216 (defswitch "quiet")
217 (defswitch "debug-lisp-search")
218 #+x86
219 (defswitch "fpu")

  ViewVC Help
Powered by ViewVC 1.1.5