source: trunk/source/level-1/l1-application.lisp

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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