Index: /trunk/ccl/level-1/l1-readloop.lisp
===================================================================
--- /trunk/ccl/level-1/l1-readloop.lisp (revision 686)
+++ /trunk/ccl/level-1/l1-readloop.lisp (revision 687)
@@ -38,18 +38,9 @@
(defvar *continuablep* nil)
(defvar *in-read-loop* nil
- "Not CL. Is T if waiting for input in the read loop")
-(defvar *listener-p* nil
- "Bound true by READ-LOOP. This is how we tell if a process is a Listener")
-
-(defparameter *inhibit-error* nil "If non-nil, ERROR just throws")
+ "Is T if waiting for input in the read loop")
+
+
(defvar *did-startup* nil)
-
-(defun process-is-listener-p (process)
- (symbol-value-in-process '*listener-p* process))
-
-(defun process-is-toplevel-listener-p (process)
- (and (symbol-value-in-process '*in-read-loop* process)
- (eql 0 (symbol-value-in-process '*break-level* process))))
@@ -63,26 +54,10 @@
(throw :toplevel nil))
-; This is the old way we did this.
-; It has the drawback that it doesn't throw out,
-; just restarts the process without cleaning up.
-#|
- (progn
- (process-interrupt *initial-process*
- #'(lambda (p)
- (let ((function.args (process.initial-form p)))
- (apply #'process-preset
- p
- (car function.args)
- (cdr function.args))))
- p)
- (loop
- (suspend-current-process))))))
-|#
(defun cancel ()
(throw :cancel :cancel))
-; It's not clear that this is the right behavior, but aborting CURRENT-PROCESS -
-; when no one's sure just what CURRENT-PROCESS is - doesn't seem right either.
+;;; It's not clear that this is the right behavior, but aborting CURRENT-PROCESS -
+;;; when no one's sure just what CURRENT-PROCESS is - doesn't seem right either.
(defun interactive-abort ()
(interactive-abort-in-process *current-process*))
@@ -99,35 +74,4 @@
-; What process-to-abort does now (5/5/95):
-; - all processes idling: cmd-. & opt-cmd-. abort event-processor
-; - one process busy: cmd-. aborts the busy process; opt-cmd-. gives dialog
-; - two or more processes busy: cmd-. & opt-cmd-. gives dialog
-; (a busy process is a non-idling listener, or any other that's not event-processor)
-
-#+notyet
-(defun process-to-abort (what)
- (let ((l (mapcan #'(lambda (x)
- (unless (or (process-exhausted-p x)
- (not (find-restart-in-process 'abort x))
- ; idling listeners:
- #|
- (and (symbol-value-in-process '*in-read-loop* x)
- (eq 0 (symbol-value-in-process '*break-level* x)))|#
- )
- (list x)))
- (reverse *active-processes*))))
- (cond
- ((null (cdr l)) (car l)) ; *current-process*
- ((and (null (cddr l))
- (not (option-key-p)))
- (if (eq (car l) *event-processor*) (cadr l) (car l)))
- (t (let ((p (catch-cancel
- (select-item-from-list l
- :window-title what
- :help-spec 15010
- :list-spec 15011
- :button-spec 15013))))
- (if (neq p :cancel) (car p)))))))
-
(defun abort (&optional condition)
(invoke-restart-no-return (find-restart 'abort condition)))
@@ -142,17 +86,4 @@
(defun abort-break ()
(invoke-restart-no-return 'abort-break))
-
-#| Doing it this way prevents abort from clearing input in the listener
-(defun abort-break ()
- (let ((res (find-restart-2 'abort)))
- (if res (invoke-restart-no-return res) (abort))))
-
-; find second restart
-(defun find-restart-2 (name &aux res)
- (dolist (cluster %restarts% res)
- (dolist (restart cluster)
- (when (eq (restart-name restart) name)
- (if res (return-from find-restart-2 restart)(setq res restart))))))
-|#
@@ -172,9 +103,5 @@
-
-
(defglobal *quitting* nil)
-
-
@@ -211,269 +138,4 @@
))
-
-
-
-
-
-
-;; Application classes
-
-(defstruct command-line-argument
- keyword
- help-string
- option-char
- long-name
- may-take-operand
- allow-multiple ; option can appear multiple times
-)
-
-(defvar *standard-help-argument*
- (make-command-line-argument
- :keyword :help
- :help-string "this text"
- :option-char #\h
- :long-name "help"))
-
-(defvar *standard-version-argument*
- (make-command-line-argument
- :keyword :version
- :help-string "print (LISP-APPLICATION-VERSION) and exit"
- :option-char #\V
- :long-name "version"))
-
-(defclass application ()
- ((command-line-arguments
- :initform
- (list *standard-help-argument* *standard-version-argument*))
- (ui-object :initform nil :initarg :ui-object :accessor application-ui-object)))
-
-(defclass ui-object ()
- ())
-
-;;; It's intended that this be specialized ...
-(defmethod ui-object-do-operation ((u ui-object) operation &rest args)
- (declare (ignore operation args)))
-
-
-(defun %usage-exit (banner exit-status other-args)
- (with-cstrs ((banner banner)
- (other-args other-args))
- (ff-call (%kernel-import ppc32::kernel-import-usage-exit)
- :address banner
- :signed-fullword exit-status
- :address other-args
- :void)))
-
-;;; Returns three values: error-flag, options-alist, non-option-arguments
-(defmethod parse-application-arguments ((a application))
- (let* ((cla (slot-value a 'command-line-arguments))
- (vals (cdr *command-line-argument-list*))
- (options ())
- (non-options ()))
- (do* ()
- ((null vals)
- (values nil (nreverse options) (nreverse non-options)))
- (let* ((val (pop vals))
- (val-len (length val))
- (short-p nil)
- (option
- (if (and (>= val-len 2)
- (eql (schar val 0) #\-))
- (if (eql (schar val 1) #\-)
- (find val cla
- :key #'command-line-argument-long-name
- :test #'(lambda (k v) (string= k v :start1 2)))
- (progn
- (setq short-p t)
- (find (schar val 1) cla
- :key #'command-line-argument-option-char))))))
- (if (null option)
- (if (and (>= val-len 1)
- (eql (schar val 0) #\-))
- (return (values :unknown-option val nil))
- (push val non-options)) ;non-option argument
- ;; We recognized the option. Is it a duplicate of
- ;; something already seen?
- (let* ((key (command-line-argument-keyword option))
- (operand nil))
- (when (and (assoc key options)
- (not (command-line-argument-allow-multiple option)))
- (return (values :duplicate-option val nil)))
- (when (command-line-argument-may-take-operand option)
- ;; A short option name can be followed by the operand,
- ;; without intervening whitespace.
- (if (and short-p (> val-len 2))
- (setq operand (subseq val 2))
- (if vals
- (setq operand (pop vals))
- (return (values :missing-operand val nil)))))
- (push (cons key operand) options)))))))
-
-(defmethod summarize-option-syntax ((a application))
- (flet ((summarize-option (o)
- (format nil "~8t-~a, --~a : ~a~%"
- (command-line-argument-option-char o)
- (command-line-argument-long-name o)
- (command-line-argument-help-string o))))
- (format nil "~{~a~}" (mapcar #'summarize-option
- (slot-value a 'command-line-arguments)))))
-
-
-;;; Process the "help" and "version" options, report parsing errors.
-(defmethod process-application-arguments ((a application) error-flag opts args)
- (declare (ignore args))
- (if (null error-flag)
- (if (assoc :help opts)
- (%usage-exit "" 0 (summarize-option-syntax a))
- (if (assoc :version opts)
- (progn
- (format t "~&~a~&" (application-version-string a))
- (force-output t)
- (#_exit 0))))
- (%usage-exit
- (format nil
- (case error-flag
- (:missing-argument "Missing argument to ~a option")
- (:duplicate-argument "Duplicate ~a option")
- (:unknown-option "Unknown option: ~a")
- (t "~a"))
- opts)
- #$EX_USAGE
- (summarize-option-syntax a))))
-
-
-;;; an example method to base a specialization on
-(defmethod toplevel-function ((a application) init-file)
- (declare (ignore init-file))
- (multiple-value-bind (error-flag options args)
- (parse-application-arguments a)
- (process-application-arguments a error-flag options args)))
-
-(defmethod application-version-string ((a application))
- "Return a string which (arbitrarily) represents the application version.
-Default version returns OpenMCL version info."
- (format nil "~&~d.~d~@[.~d~]~@[-~a~]~&"
- *openmcl-major-version*
- *openmcl-minor-version*
- (unless (zerop *openmcl-revision*)
- *openmcl-revision*)
- *openmcl-suffix*))
-
-(defmethod application-ui-operation ((a application) operation &rest args)
- (let* ((ui-object (application-ui-object a)))
- (when ui-object
- (apply #'ui-object-do-operation ui-object operation args))))
-
-
-
-
-
-(defun find-restart-in-process (name p)
- (without-interrupts
- (let ((restarts (symbol-value-in-process '%restarts% p)))
- (dolist (cluster restarts)
- (dolist (restart cluster)
- (when (and (or (eq restart name) (eq (restart-name restart) name)))
- (return-from find-restart-in-process restart)))))))
-
-
-
-; specialize this for your application
-(defmethod open-application ((self application) startup)
- (declare (ignore startup))
- nil)
-
-; specialize this for your application
-(defmethod open-application-document ((a application) path &optional startup)
- (declare (ignore path startup)))
-
-(defmethod application-name ((app application)) nil)
-(defmethod application-init-file ((app application)) nil)
-
-
-(defclass lisp-development-system (application)
- ((command-line-arguments
- :initform
- (list *standard-help-argument*
- *standard-version-argument*
- (make-command-line-argument
- :option-char #\n
- :long-name "no-init"
- :keyword :noinit
- :help-string "suppress loading of init file")
- (make-command-line-argument
- :option-char #\e
- :long-name "eval"
- :keyword :eval
- :help-string "evaluate