← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/lsp/cmdline.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2007-04-09 11:51:51 UTC
  • mfrom: (1.1.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070409115151-ql8cr0kalzx1jmla
Tags: 0.9i-20070324-2
Upload to unstable. 

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/lsp/cmdline.lsp
12
12
 
13
13
(in-package "SYSTEM")
14
14
 
15
 
(export '(*lisp-init-file-list* command-args process-command-args))
 
15
(export '(*lisp-init-file-list*
 
16
          *help-message*
 
17
          +default-command-arg-rules+
 
18
          command-args
 
19
          process-command-args))
16
20
 
17
21
(defvar *lisp-init-file-list* '("~/.ecl" "~/.eclrc")
18
22
  "List of files automatically loaded when ECL is invoked.")
19
23
 
 
24
(defvar *help-message* "
 
25
Usage: ecl [-? | --help]
 
26
           [-dir dir] [-load file] [-shell file] [-eval expr] [-rc | -norc] [-hp | -nohp]
 
27
           [[-o ofile] [-c [cfile]] [-h [hfile]] [-data [datafile]] [-s] [-q]
 
28
            -compile file]
 
29
 
 
30
"
 
31
 "Prints a help message about command line arguments of ECL")
 
32
 
20
33
(defun command-args ()
21
34
  "Returns the command line arguments as list"
22
35
  (loop for i from 0 below (argc)
23
36
        collect (argv i)))
24
37
 
25
 
(defun help-message (stream)
26
 
  "Prints a help message about command line arguments of ECL"
27
 
  (princ "
28
 
Usage: ecl [-? | --help]
29
 
           [-dir dir] [-load file] [-shell file] [-eval expr] [-rc | -norc]
30
 
           [[-o ofile] [-c [cfile]] [-h [hfile]] [-data [datafile]] [-s] [-q]
31
 
            -compile file]
32
 
 
33
 
"
34
 
         stream))
35
 
 
36
38
(defun command-arg-error (str &rest fmt-args)
37
39
  ;; Format an error message and quit
38
40
  (declare (si::c-local))
39
41
  (apply #'format *error-output* str fmt-args)
40
 
  (help-message *error-output*)
 
42
  (princ *help-message* *error-output*)
41
43
  (quit 1))
42
44
 
43
 
(defconstant +command-arg-rules+
44
 
  '(("--help" 0 #0=(progn (help-message *standard-output*) (quit)) :noloadrc)
 
45
(defconstant +default-command-arg-rules+
 
46
  '(("--help" 0 #0=(progn (princ *help-message* *standard-output*) (quit)) :noloadrc)
45
47
    ("-?" 0 #0# :noloadrc)
46
48
    ("-h" 0 #0# :noloadrc)
47
49
    ("-norc" 0 nil :noloadrc)
70
72
    ("-h" 1 (setq h-file 1))
71
73
    ("-data" 1 (setq data-file 1))
72
74
    ("-q" 0 (setq verbose nil))
 
75
    ("-hp" 0 (setf *relative-package-names* t))
 
76
    ("-nohp" 0 (setf *relative-package-names* nil))
73
77
    ("-s" 0 (setq system-p t))))
74
78
 
75
 
(defun produce-init-code (option-list rules error-on-unknown)
76
 
  (declare (si::c-local))
 
79
(defun produce-init-code (option-list rules)
77
80
  (do* ((commands '())
 
81
        (stop nil)
78
82
        (loadrc t))
79
 
       ((null option-list)
 
83
       ((or stop (null option-list))
80
84
        (values `(let ((output-file t)
81
85
                       (c-file nil)
82
86
                       (h-file nil)
86
90
                       (quit nil))
87
91
                   ,@(nreverse commands)
88
92
                   (when quit (quit 0)))
89
 
                loadrc))
 
93
                loadrc
 
94
                option-list))
90
95
    (let* ((option (pop option-list))
91
96
           (rule (assoc option rules :test #'string=)))
92
 
      (if (null rule)
93
 
          (if error-on-unknown
94
 
              (command-arg-error "Unknown command line option ~A.~%" option)
95
 
              (setf option-list nil))
96
 
          (let ((pattern (copy-tree (third rule))))
97
 
            (case (fourth rule)
98
 
              (:noloadrc (setf loadrc nil))
99
 
              (:loadrc (setf loadrc t))
100
 
              (:stop (setf option-list nil)))
101
 
            (let ((pattern (copy-tree (third rule))))
102
 
              (unless (zerop (second rule))
103
 
                (when (null option-list)
104
 
                  (command-arg-error
105
 
                   "Missing argument after command line option ~A.~%"
106
 
                   option))
107
 
                (nsubst (pop option-list) 1 pattern))
108
 
              (push pattern commands)))))))
 
97
      (unless rule
 
98
        ;; If there is a default rule, group all remaining arguments
 
99
        ;; including the unmatched one, and pass them to this rule.
 
100
        (setf rule (assoc "*DEFAULT*" rules :test #'string=)
 
101
              option-list `('(,option ,@option-list))
 
102
              stop t)
 
103
        (unless rule
 
104
          (command-arg-error "Unknown command line option ~A.~%" option)))
 
105
      (let ((pattern (copy-tree (third rule))))
 
106
        (case (fourth rule)
 
107
          (:noloadrc (setf loadrc nil))
 
108
          (:loadrc (setf loadrc t))
 
109
          (:stop (setf option-list nil)))
 
110
        (let ((pattern (copy-tree (third rule))))
 
111
          (unless (zerop (second rule))
 
112
            (when (null option-list)
 
113
              (command-arg-error
 
114
               "Missing argument after command line option ~A.~%"
 
115
               option))
 
116
            (nsubst (pop option-list) 1 pattern))
 
117
          (push pattern commands))))))
109
118
 
110
119
(defun process-command-args (&key
111
120
                             (args (rest (command-args)))
112
 
                             (rules +command-arg-rules+)
113
 
                             (error-on-unknown t))
 
121
                             (rules +default-command-arg-rules+))
114
122
"PROCESS-COMMAND-ARGS takes a list of arguments and processes according
115
123
to a set of rules. These rules are of the format
116
124
 
125
133
loaded before evaluating all forms.
126
134
 
127
135
An excerpt of the rules used by ECL:
128
 
'((\"--help\" 0 #0=(progn (help-message *standard-output*) (quit)) :noloadrc)
 
136
'((\"--help\" 0 #0=(progn (princ *help-message* *standard-output*) (quit))
 
137
               :noloadrc)
129
138
  (\"-?\" 0 #0# :noloadrc)
130
139
  (\"-h\" 0 #0# :noloadrc)
131
140
  (\"-norc\" 0 nil :noloadrc)
133
142
  (\"-eval\" 1 (eval (read-from-string 1))))
134
143
"
135
144
  (multiple-value-bind (commands loadrc)
136
 
      (produce-init-code args rules error-on-unknown)
 
145
      (produce-init-code args rules)
137
146
    (handler-case
138
147
        (progn
139
148
          (when loadrc