/[meta-cvs]/meta-cvs/F-9E93CACBDB115633C66D0EF9B052C490
ViewVC logotype

Contents of /meta-cvs/F-9E93CACBDB115633C66D0EF9B052C490

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Thu Oct 31 04:06:01 2002 UTC (11 years, 5 months ago) by kaz
Branch: MAIN
Changes since 1.13: +3 -0 lines
* code/mcvs-package.lisp: New file, defines META-CVS package.

* code/purge.lisp: Put all symbols in new package.
* code/restore.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/install.sh: Likewise.
* code/restart.lisp: Likewise.
* code/update.lisp: Likewise.
* code/move.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/branch.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/link.lisp: Likewise.
* code/split.lisp: Likewise.
* code/watch.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/add.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/print.lisp: Likewise.
* code/types.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/error.lisp: Likewise.
* code/options.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/create.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/remap.lisp: Likewise.

* code/mapping.lisp: Put symbols in new package. Replace use
of CLISP specific substring function with subseq.
* code/filt.lisp: Likewise.

* code/mcvs-main.lisp: Put symbols in new package. The mcvs
function is renamed to main.

* code/install.sh: Generate mcvs script that uses qualified name
of new startup functiont to start the software.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (require "find-bind")
6 (require "split")
7 (require "error")
8 (require "mcvs-package")
9 (provide "options")
10
11 (in-package "META-CVS")
12
13 (defvar *nometa-option* nil)
14 (defvar *meta-option* nil)
15 (defvar *metaonly-option* nil)
16
17 (defun option-spec-expand (num-args string-list)
18 (mapcar #'(lambda (string) (list string num-args))
19 string-list))
20
21 (defmacro option-spec (&rest option-specs)
22 `(append ,@(mapcar #'(lambda (spec)
23 (destructuring-bind (number word &rest strings) spec
24 (when (not (string= (symbol-name word) "ARG"))
25 (error "OPTIONS: word \"ARG\" expected."))
26 `(option-spec-expand ,number ',strings)))
27 option-specs)))
28
29 (defmacro define-option-constant (var &rest option-specs)
30 `(defconstant ,var (option-spec ,@option-specs)))
31
32 (defun parse-opt (arguments option-spec)
33 (flet ((process-option (arg)
34 (let* ((split-opt (split-fields arg #(#\=)))
35 (opt-name (first split-opt))
36 (opt-arg (second split-opt))
37 (spec (find opt-name option-spec
38 :test #'string=
39 :key #'first)))
40 (when (null spec)
41 (error "unknown option ~a." opt-name))
42 (when opt-arg
43 (push opt-arg arguments))
44 (let ((num-req-params (second spec))
45 (opt-args ()))
46 (dotimes (i num-req-params)
47 (let ((opt-arg (pop arguments)))
48 (when (null opt-arg)
49 (error "option ~a requires ~a parameter~:p."
50 opt-name num-req-params))
51 (push opt-arg opt-args)))
52 (cons opt-name (nreverse opt-args))))))
53 (let ((parsed-options ()))
54 (loop
55 (if (null arguments)
56 (return))
57 (let ((arg (pop arguments)))
58 (cond
59 ((string= arg "--")
60 (return))
61 ((and (> (length arg) 2) (string= (subseq arg 0 2) "--"))
62 (push (process-option (subseq arg 2)) parsed-options))
63 ((and (> (length arg) 1) (char= (char arg 0) #\-))
64 (let ((num-chars (- (length arg) 1))
65 (last-iter (- (length arg) 2)))
66 (dotimes (i num-chars)
67 (let ((option (subseq arg (+ i 1) (+ i 2)))
68 (arg (subseq arg (+ i 2))))
69 (when (< i last-iter)
70 (push arg arguments))
71 (let ((result (process-option option)))
72 (push result parsed-options)
73 (when (and (second result)
74 (/= i (- (length arg) 2)))
75 (return))
76 (when (< i last-iter)
77 (pop arguments)))))))
78 (t (push arg arguments)
79 (return)))))
80 (values (nreverse parsed-options) arguments))))
81
82 (defun format-opt (options)
83 "Convert list of options as produced by parse-opt back into a list
84 of strings."
85 (mapcan #'(lambda (option-list)
86 (let ((option (first option-list))
87 (arg (rest option-list)))
88 (if (> (length option) 1)
89 (cons (format nil "--~a" option) arg)
90 (cons (format nil "-~a" option) arg)))) options))
91
92 (defun filter-global-options (opts)
93 "Processes and removes any Meta-CVS-specific options."
94 (find-bind (:test #'string= :key #'first)
95 (remainder (meta "meta")
96 (metaonly "metaonly")
97 (nometa "nometa")
98 (ec "error-continue")
99 (et "error-terminate")
100 (debug "debug"))
101 opts
102 (when (and meta nometa)
103 (error "cannot specify both --nometa and --meta"))
104 (when (and metaonly nometa)
105 (error "cannot specify both --nometa and --metaonly"))
106 (setf *meta-option* meta)
107 (setf *metaonly-option* metaonly)
108 (setf *nometa-option* nometa)
109 (when debug
110 (setf *mcvs-chatter-level* *mcvs-debug*))
111 (cond
112 (et (setf *mcvs-error-treatment* :terminate))
113 (ec (setf *mcvs-error-treatment* :continue)))
114 remainder))

  ViewVC Help
Powered by ViewVC 1.1.5