;;;;  command-line.lsp -- command line processing
;;;;
;;;;  FIXME: Insert appropriate copyright foo

(in-package "SYSTEM")

(export '(*lisp-init-file-list*))

(defvar *lisp-init-file-list* '("~/.ecl" "~/.eclrc")
  "List of files automatically loaded when ECL is invoked.")

#-ecl-min
;; Might be nice to have this visible to the user
(defun command-arguments ()
  "Returns the command line arguments as list"
  (loop for i from 0 below (argc)
	collect (argv i)))

#-ecl-min
(defun help-message (stream)
  "Prints a help message about command line arguments of ECL"
  (princ "Usage: ecl [-? | --help]
           [-dir dir] [-load file] [-shell file] [-eval expr] [-norc]
           [-compile file [-o ofile] [-c [cfile]] [-h [hfile]]
                          [-data [datafile]] [-s] [-q]]
"
	 stream))

#-ecl-min
(defun command-arg-error (str &rest fmt-args)
  "Format an error message an quit"
  (apply #'format *error-output* str fmt-args)
  (help-message *error-output*)
  (quit 1))

#-ecl-min
(defun list-cut (list start end)
  "Returns `list' without everything between the positions `start' and `end'.
What has been deleted is returned as second value."
  (values
   (append
    (subseq list 0 start)
    (subseq list (1+ end)))
   (subseq list start (1+ end))))
  
(defun process-command-args (&optional (args (rest (command-arguments))))
  #-ecl-min
  (handler-case 
      (loop with load-rc = t
	    and commands = nil
	    and quit-after-init = nil
	    and stop-processing = nil
	    and option = nil
	    while args
	    until stop-processing
	    do (setq option (pop args))
	    do (flet ((pop-arg ()
			(or (pop args)
			    (command-arg-error "Missing argument to command line option ~A.~%"
					       option)))
		      (option-is (what)
			(string= what option))
		      (get-arg (name &optional default)
			(let ((pos (position name args :test #'string=)))
			  (if pos
			      (if (= pos (1- (length args)))
				  (command-arg-error "Missing argument to command line option ~A.~%"
						     name)
				  (multiple-value-bind (new-args retrieved)
				      (list-cut args pos (1+ pos))
				    (setq args new-args)
				    (second retrieved)))
				  default))))
		 (macrolet ((thunk (let-forms &body body)
			      `(push (let ,let-forms
				       (lambda ()
					 ,@body))
				commands)))
		   (cond
		     ((option-is "-dir")
		      (setf (logical-pathname-translations "SYS")
			    `(("**;*.*" ,(merge-pathnames "**/*.*" (truename (pop-arg)))))))
		     ;; FIXME: Multiple -compile arguments will break
		     ;; because wrong -o/-c/-h/... arguments will be
		     ;; fetched.
		     ((option-is "-compile")
		      (setq quit-after-init t)
		      (thunk ((file (pop-arg))
			      (out (get-arg "-o" t))
			      (c (get-arg "-c"))
			      (h (get-arg "-h"))
			      (data (get-arg "-data"))
			      (verbose (not (get-arg "-q")))
			      (sys (get-arg "-s")))
			     (if (nth-value 3
					    (compile-file file
							  :output-file out
							  :c-file c
							  :h-file h
							  :data-file data
							  :verbose verbose
							  :system-p sys))
				 (command-arg-error "Compiling failed.~%"))))
		     ((option-is "-load")
		      (thunk ((file (pop-arg)))
			     (load file :verbose t)))
		     ((option-is "-shell")
		      (setq quit-after-init t)
		      (thunk ((file (pop-arg)))
			     (load file :verbose nil)))
		     ((option-is "-eval")
		      (thunk ((body (pop-arg)))
			     (eval (read-from-string body))))
		     ((option-is "-norc")
		      (setq load-rc nil))
		     ((option-is "--")
		      (setq stop-processing t))	; loop-finish?
		     (t
		      (command-arg-error "Unknown command line option ~A.~%"
					 option)))))
	    finally
	    (when load-rc
	      (some (lambda (file)
		      ;; search-list?
		      (load file :if-does-not-exist nil :search-list nil :verbose nil))
		    *lisp-init-file-list*))
	    (mapc #'funcall
		  (nreverse commands))
	    (when quit-after-init
	      (quit 0)))
    (error (c)
	   (format *error-output* "An error occurred during initialization: ~A.~%"
		   c)
	   (quit 1))))

;; EOF
