1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; Portions Copyright (C) 2001-2009, Clozure Associates |
---|
5 | ;;; This file is part of Clozure CL. |
---|
6 | ;;; |
---|
7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
11 | ;;; conflict, the preamble takes precedence. |
---|
12 | ;;; |
---|
13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
14 | ;;; |
---|
15 | ;;; The LLGPL is also available online at |
---|
16 | ;;; http://opensource.franz.com/preamble.html |
---|
17 | |
---|
18 | (in-package "CCL") |
---|
19 | |
---|
20 | ;; Application classes |
---|
21 | |
---|
22 | (defstruct command-line-argument |
---|
23 | keyword |
---|
24 | help-string |
---|
25 | option-char |
---|
26 | long-name |
---|
27 | may-take-operand |
---|
28 | allow-multiple ; option can appear multiple times |
---|
29 | ) |
---|
30 | |
---|
31 | (defvar *standard-help-argument* |
---|
32 | (make-command-line-argument |
---|
33 | :keyword :help |
---|
34 | :help-string "this text" |
---|
35 | :option-char #\h |
---|
36 | :long-name "help")) |
---|
37 | |
---|
38 | (defvar *standard-version-argument* |
---|
39 | (make-command-line-argument |
---|
40 | :keyword :version |
---|
41 | :help-string "print (LISP-IMPLEMENTATION-VERSION) and exit" |
---|
42 | :option-char #\V |
---|
43 | :long-name "version")) |
---|
44 | |
---|
45 | (defvar *standard-terminal-encoding-argument* |
---|
46 | (make-command-line-argument |
---|
47 | :option-char #\K |
---|
48 | :long-name "terminal-encoding" |
---|
49 | :help-string "specify character encoding to use for *TERMINAL-IO*" |
---|
50 | :may-take-operand t |
---|
51 | :keyword :terminal-encoding |
---|
52 | :allow-multiple nil)) |
---|
53 | |
---|
54 | (defclass application () |
---|
55 | ((command-line-arguments |
---|
56 | :initform |
---|
57 | (list *standard-help-argument* *standard-version-argument*)) |
---|
58 | (ui-object :initform nil :initarg :ui-object :accessor application-ui-object))) |
---|
59 | |
---|
60 | (defclass ui-object () |
---|
61 | ()) |
---|
62 | |
---|
63 | ;;; It's intended that this be specialized ... |
---|
64 | (defmethod ui-object-do-operation ((u ui-object) operation &rest args) |
---|
65 | (declare (ignore operation args))) |
---|
66 | |
---|
67 | |
---|
68 | (defun %usage-exit (banner exit-status other-args) |
---|
69 | (with-cstrs ((banner banner) |
---|
70 | (other-args other-args)) |
---|
71 | (ff-call (%kernel-import target::kernel-import-usage-exit) |
---|
72 | :address banner |
---|
73 | :signed-fullword exit-status |
---|
74 | :address other-args |
---|
75 | :void))) |
---|
76 | |
---|
77 | (defloadvar *unprocessed-command-line-arguments* ()) |
---|
78 | |
---|
79 | ;;; Returns four values: error-flag, options-alist, non-option-arguments, unprocessed arguments |
---|
80 | (defmethod parse-application-arguments ((a application)) |
---|
81 | (let* ((cla (slot-value a 'command-line-arguments)) |
---|
82 | (vals (cdr *command-line-argument-list*)) |
---|
83 | (options ()) |
---|
84 | (non-options ()) |
---|
85 | (rest-arg nil)) |
---|
86 | (do* () |
---|
87 | ((null vals) |
---|
88 | (values nil (nreverse options) (nreverse non-options) rest-arg)) |
---|
89 | (let* ((val (pop vals)) |
---|
90 | (val-len (length val)) |
---|
91 | (short-p nil) |
---|
92 | (option |
---|
93 | (if (and (>= val-len 2) |
---|
94 | (eql (schar val 0) #\-)) |
---|
95 | (if (eql (schar val 1) #\-) |
---|
96 | (find val cla |
---|
97 | :key #'command-line-argument-long-name |
---|
98 | :test #'(lambda (k v) (string= k v :start1 2))) |
---|
99 | (progn |
---|
100 | (setq short-p t) |
---|
101 | (find (schar val 1) cla |
---|
102 | :key #'command-line-argument-option-char)))))) |
---|
103 | (if (null option) |
---|
104 | (if (and (>= val-len 1) |
---|
105 | (eql (schar val 0) #\-)) |
---|
106 | (if (and (= val-len 2) |
---|
107 | (eql (schar val 1) #\-)) |
---|
108 | (setq rest-arg vals |
---|
109 | vals nil) |
---|
110 | (return (values :unknown-option val nil nil))) |
---|
111 | (push val non-options)) ;non-option argument |
---|
112 | ;; We recognized the option. Is it a duplicate of |
---|
113 | ;; something already seen? |
---|
114 | (let* ((key (command-line-argument-keyword option)) |
---|
115 | (operand nil)) |
---|
116 | (when (and (assoc key options) |
---|
117 | (not (command-line-argument-allow-multiple option))) |
---|
118 | (return (values :duplicate-option val nil))) |
---|
119 | (when (command-line-argument-may-take-operand option) |
---|
120 | ;; A short option name can be followed by the operand, |
---|
121 | ;; without intervening whitespace. |
---|
122 | (if (and short-p (> val-len 2)) |
---|
123 | (setq operand (subseq val 2)) |
---|
124 | (if vals |
---|
125 | (setq operand (pop vals)) |
---|
126 | (return (values :missing-operand val nil))))) |
---|
127 | (push (cons key operand) options))))))) |
---|
128 | |
---|
129 | (defmethod summarize-option-syntax ((a application)) |
---|
130 | (flet ((summarize-option (o) |
---|
131 | (format nil "~8t-~a, --~a : ~a~%" |
---|
132 | (command-line-argument-option-char o) |
---|
133 | (command-line-argument-long-name o) |
---|
134 | (command-line-argument-help-string o)))) |
---|
135 | (format nil "~{~a~}" (mapcar #'summarize-option |
---|
136 | (slot-value a 'command-line-arguments))))) |
---|
137 | |
---|
138 | |
---|
139 | ;;; Process the "help" and "version" options, report parsing errors. |
---|
140 | (defmethod process-application-arguments ((a application) error-flag opts args) |
---|
141 | (declare (ignore args)) |
---|
142 | (if (null error-flag) |
---|
143 | (if (assoc :help opts) |
---|
144 | (%usage-exit "" 0 (summarize-option-syntax a)) |
---|
145 | (if (assoc :version opts) |
---|
146 | ;; Can't use lisp streams yet. |
---|
147 | (progn |
---|
148 | (with-cstrs ((s (format nil "~&~a~&" (application-version-string a)))) |
---|
149 | (fd-write 1 s (%cstrlen s))) |
---|
150 | (#_ _exit 0)) |
---|
151 | (let* ((encoding (assoc :terminal-encoding opts))) |
---|
152 | (when (cdr encoding) |
---|
153 | (let* ((encoding-name |
---|
154 | (let* ((*package* (find-package "KEYWORD"))) |
---|
155 | (ignore-errors (read-from-string (cdr encoding)))))) |
---|
156 | (when encoding-name |
---|
157 | (let* ((character-encoding (lookup-character-encoding encoding-name))) |
---|
158 | (when character-encoding |
---|
159 | (setq *terminal-character-encoding-name* |
---|
160 | (character-encoding-name character-encoding)))))))))) |
---|
161 | (%usage-exit |
---|
162 | (format nil |
---|
163 | (case error-flag |
---|
164 | (:missing-argument "Missing argument to ~a option") |
---|
165 | (:duplicate-argument "Duplicate ~a option") |
---|
166 | (:unknown-option "Unknown option: ~a") |
---|
167 | (t "~a")) |
---|
168 | opts) |
---|
169 | #-windows-target #-android-target #$EX_USAGE #+android-target 64 #+windows-target #$EXIT_FAILURE |
---|
170 | (summarize-option-syntax a)))) |
---|
171 | |
---|
172 | |
---|
173 | ;;; an example method to base a specialization on |
---|
174 | (defmethod toplevel-function ((a application) init-file) |
---|
175 | (declare (ignore init-file)) |
---|
176 | nil ) |
---|
177 | |
---|
178 | (defmethod toplevel-function :before ((a application) init-file) |
---|
179 | (declare (ignore init-file)) |
---|
180 | (multiple-value-bind (error-flag options args rest-arg) |
---|
181 | (parse-application-arguments a) |
---|
182 | (setq *unprocessed-command-line-arguments* rest-arg) |
---|
183 | (process-application-arguments a error-flag options args) |
---|
184 | (let* ((encoding (lookup-character-encoding *terminal-character-encoding-name*))) |
---|
185 | (when encoding |
---|
186 | (set-terminal-encoding (character-encoding-name encoding)))))) |
---|
187 | |
---|
188 | (defmethod repl-function-name ((a application)) |
---|
189 | "Return the name of a function that should be run in a TTY-like |
---|
190 | listener thread (if that concept makes sense); return NIL otherwise." |
---|
191 | nil) |
---|
192 | |
---|
193 | (defmethod application-version-string ((a application)) |
---|
194 | "Return a string which (arbitrarily) represents the application version. |
---|
195 | Default version returns Clozure CL version info." |
---|
196 | (lisp-implementation-version)) |
---|
197 | |
---|
198 | (defmethod application-ui-operation ((a application) operation &rest args) |
---|
199 | (let* ((ui-object (application-ui-object a))) |
---|
200 | (when ui-object |
---|
201 | (apply #'ui-object-do-operation ui-object operation args)))) |
---|
202 | |
---|
203 | |
---|
204 | |
---|
205 | |
---|
206 | (defmethod application-init-file ((app application)) nil) |
---|
207 | |
---|
208 | |
---|
209 | (defclass lisp-development-system (application) |
---|
210 | ((command-line-arguments |
---|
211 | :initform |
---|
212 | (list *standard-help-argument* |
---|
213 | *standard-version-argument* |
---|
214 | *standard-terminal-encoding-argument* |
---|
215 | (make-command-line-argument |
---|
216 | :option-char #\n |
---|
217 | :long-name "no-init" |
---|
218 | :keyword :noinit |
---|
219 | :help-string "suppress loading of init file") |
---|
220 | (make-command-line-argument |
---|
221 | :option-char #\e |
---|
222 | :long-name "eval" |
---|
223 | :keyword :eval |
---|
224 | :help-string "evaluate <form> (may need to quote <form> in shell)" |
---|
225 | :may-take-operand t |
---|
226 | :allow-multiple t) |
---|
227 | (make-command-line-argument |
---|
228 | :option-char #\l |
---|
229 | :long-name "load" |
---|
230 | :keyword :load |
---|
231 | :help-string "load <file>" |
---|
232 | :may-take-operand t |
---|
233 | :allow-multiple t) |
---|
234 | (make-command-line-argument |
---|
235 | :option-char #\T |
---|
236 | :long-name "set-lisp-heap-gc-threshold" |
---|
237 | :help-string "set lisp-heap-gc-threshold to <n>" |
---|
238 | :keyword :gc-threshold |
---|
239 | :may-take-operand t |
---|
240 | :allow-multiple nil) |
---|
241 | (make-command-line-argument |
---|
242 | :option-char #\Q |
---|
243 | :long-name "quiet" |
---|
244 | :help-string "if --batch, also suppress printing of heralds, prompts" |
---|
245 | :keyword :quiet |
---|
246 | :may-take-operand nil |
---|
247 | :allow-multiple nil) |
---|
248 | )) |
---|
249 | (initial-listener-process :initform nil))) |
---|
250 | |
---|
251 | (defparameter *application* |
---|
252 | (make-instance 'lisp-development-system)) |
---|
253 | |
---|
254 | (defvar *load-lisp-init-file* t) |
---|
255 | (defvar *lisp-startup-parameters* ()) |
---|
256 | |
---|
257 | (defmethod process-application-arguments ((a lisp-development-system) |
---|
258 | error-flag options args) |
---|
259 | (declare (ignorable error-flag)) |
---|
260 | (call-next-method) ; handle help, errors |
---|
261 | (if args |
---|
262 | (%usage-exit (format nil "Unrecognized non-option arguments: ~a" args) |
---|
263 | #-windows-target #-android-target #$EX_USAGE #+android-target 64 #+windows-target #$EXIT_FAILURE |
---|
264 | (summarize-option-syntax a)) |
---|
265 | (progn |
---|
266 | (setq *load-lisp-init-file* (not (assoc :noinit options)) |
---|
267 | *quiet-flag* (if *batch-flag* |
---|
268 | (not (null (assoc :quiet options)))) |
---|
269 | *lisp-startup-parameters* |
---|
270 | (mapcan #'(lambda (x) |
---|
271 | (and (member (car x) '(:load :eval :gc-threshold)) (list x))) |
---|
272 | options))))) |
---|
273 | |
---|
274 | |
---|
275 | (defmethod repl-function-name ((a lisp-development-system)) |
---|
276 | 'listener-function) |
---|
277 | |
---|
278 | (defmethod toplevel-function ((a lisp-development-system) init-file) |
---|
279 | (let* ((sr (input-stream-shared-resource *terminal-input*)) |
---|
280 | (f (or (repl-function-name a) 'listener-function))) |
---|
281 | (with-slots (initial-listener-process) a |
---|
282 | (setq initial-listener-process |
---|
283 | (make-mcl-listener-process |
---|
284 | "listener" |
---|
285 | *terminal-input* |
---|
286 | *terminal-output* |
---|
287 | #'(lambda () (when sr (setf (shared-resource-primary-owner sr) |
---|
288 | *initial-process*))) |
---|
289 | :initial-function |
---|
290 | #'(lambda () |
---|
291 | (startup-ccl (and *load-lisp-init-file* init-file)) |
---|
292 | (funcall f) |
---|
293 | nil) |
---|
294 | :close-streams nil |
---|
295 | :control-stack-size *initial-listener-default-control-stack-size* |
---|
296 | :value-stack-size *initial-listener-default-value-stack-size* |
---|
297 | :temp-stack-size *initial-listener-default-temp-stack-size* |
---|
298 | :class 'tty-listener |
---|
299 | :process initial-listener-process)))) |
---|
300 | (%set-toplevel (lambda () |
---|
301 | (with-standard-initial-bindings |
---|
302 | (housekeeping-loop)))) |
---|
303 | (toplevel)) |
---|
304 | |
---|
305 | (defun housekeeping-loop () |
---|
306 | (with-standard-abort-handling nil |
---|
307 | (loop |
---|
308 | #+windows-target (#_SleepEx 333 #$true) |
---|
309 | #-windows-target (%nanosleep *periodic-task-seconds* *periodic-task-nanoseconds*) |
---|
310 | (housekeeping)))) |
---|
311 | |
---|
312 | |
---|
313 | (defmethod application-init-file ((app lisp-development-system)) |
---|
314 | ;; This is the init file loaded before cocoa. |
---|
315 | #+unix '("home:ccl-init" "home:\\.ccl-init") |
---|
316 | #+windows "home:ccl-init") |
---|