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

Last change on this file since 15326 was 15326, checked in by gb, 8 years ago

Reset the initial values of *LOAD-LISP-INIT-FILE* and
*LISP-STARTUP-PARAMETERS* in each session. (The first of these
changes means that an image saved from an image run with -n will try
to load its init file unless the saved image processes -n; that's an
obscure but incompatible change.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.9 KB
RevLine 
[692]1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
[13067]4;;;   Portions Copyright (C) 2001-2009, Clozure Associates
[13066]5;;;   This file is part of Clozure CL. 
[692]6;;;
[13066]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
[692]9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[692]11;;;   conflict, the preamble takes precedence. 
12;;;
[13066]13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
[692]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
[9903]41   :help-string "print (LISP-IMPLEMENTATION-VERSION) and exit"
[692]42   :option-char #\V
43   :long-name "version"))
44
[5313]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
[692]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))
[1968]71    (ff-call (%kernel-import target::kernel-import-usage-exit)
[692]72             :address banner
73             :signed-fullword exit-status
74             :address other-args
75             :void)))
76
[4609]77(defloadvar *unprocessed-command-line-arguments* ())
78
79;;; Returns four values: error-flag, options-alist, non-option-arguments, unprocessed arguments
[692]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 ())
[4609]84         (non-options ())
85         (rest-arg nil))
[692]86    (do* ()
87         ((null vals)
[4609]88          (values nil (nreverse options) (nreverse non-options) rest-arg))
[692]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) #\-))
[4609]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)))
[692]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)
[6970]146        ;; Can't use lisp streams yet.
[692]147        (progn
[6970]148          (with-cstrs ((s (format nil "~&~a~&" (application-version-string a))))
149            (fd-write 1 s (%cstrlen s)))
150          (#_ _exit 0))
[5313]151        (let* ((encoding (assoc :terminal-encoding opts)))
[10275]152          (when (cdr encoding)
153            (let* ((encoding-name
[5313]154                    (let* ((*package* (find-package "KEYWORD")))
[10275]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))))))))))
[692]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)
[14510]169     #-windows-target #-android-target #$EX_USAGE #+android-target 64 #+windows-target #$EXIT_FAILURE
[692]170     (summarize-option-syntax a))))
171               
172
173;;; an example method to base a specialization on
[6933]174(defmethod toplevel-function  ((a application) init-file)
[692]175  (declare (ignore init-file))
[6933]176  nil )
177
178(defmethod toplevel-function :before ((a application) init-file)
179  (declare (ignore init-file))
[4609]180  (multiple-value-bind (error-flag options args rest-arg)
[692]181      (parse-application-arguments a)
[4609]182    (setq *unprocessed-command-line-arguments* rest-arg)
[5313]183    (process-application-arguments a error-flag options args)
[10275]184    (let* ((encoding (lookup-character-encoding *terminal-character-encoding-name*)))
185      (when encoding
186         (set-terminal-encoding (character-encoding-name encoding))))))
[692]187
[11929]188(defmethod repl-function-name ((a application))
189  "Return the name of a function that should be run in a TTY-like
190listener thread (if that concept makes sense); return NIL otherwise."
191  nil)
192
[692]193(defmethod application-version-string ((a application))
194  "Return a string which (arbitrarily) represents the application version.
[13066]195Default version returns Clozure CL version info."
[7281]196  (lisp-implementation-version))
[692]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
[6933]205
[692]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*
[5313]214          *standard-terminal-encoding-argument*
[692]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
[2070]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)
[5892]248          ))
249   (initial-listener-process :initform nil)))
[692]250
251(defparameter *application*
252  (make-instance 'lisp-development-system))
253
[15326]254(defloadvar *load-lisp-init-file* t)
255(defloadvar *lisp-startup-parameters* ())
[692]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)
[14510]263                 #-windows-target #-android-target #$EX_USAGE #+android-target 64 #+windows-target #$EXIT_FAILURE
[692]264                 (summarize-option-syntax a))
[5313]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)))))
[692]273       
274
[11929]275(defmethod repl-function-name ((a lisp-development-system))
276  'listener-function)
277
[692]278(defmethod toplevel-function ((a lisp-development-system) init-file)
[11929]279  (let* ((sr (input-stream-shared-resource *terminal-input*))
280         (f (or (repl-function-name a) 'listener-function)))
[5892]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))
[11929]292                 (funcall f)
[5892]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*
[5979]298             :class 'tty-listener
[5892]299             :process initial-listener-process))))
[14362]300  (%set-toplevel (lambda ()
301                   (with-standard-initial-bindings
302                       (housekeeping-loop))))
[692]303  (toplevel))
304
[8165]305(defun housekeeping-loop ()
306  (with-standard-abort-handling nil 
307    (loop
[10823]308      #+windows-target (#_SleepEx 333 #$true)
309      #-windows-target (%nanosleep *periodic-task-seconds* *periodic-task-nanoseconds*)
[8165]310      (housekeeping))))
311 
[692]312
313(defmethod application-init-file ((app lisp-development-system))
[7487]314  ;; This is the init file loaded before cocoa.
[10914]315  #+unix '("home:ccl-init" "home:\\.ccl-init")
316  #+windows "home:ccl-init")
Note: See TracBrowser for help on using the repository browser.