;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*-
;;;;
;;;;  top.lsp -- Top-level loop, break loop, and error handlers
;;;;
;;;;  Copyright (c) 1990, Giuseppe Attardi.

;;;;  Copyright (c) 2010-2013, Jean-Claude Beaudoin.

;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Lesser General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 3 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../../Copyright' for full details.
;;;;
;;;;  Revised on July 11, by Carl Hoffman.
;;;;  Modified Oct 1986 by Ken Rimey.
;;;;  Reworked March 1987, by Edward Wang.
;;;;  Merged into new distribution Sept 1987, by Edward Wang.
;;;;  Reworked for Threads November 1988, by Giuseppe Attardi.
;;;;  Reworked for CLOS November 1988, by Giuseppe Attardi.
;;;;  Updated May 2009, by Jean-Claude Beaudoin

(in-package "SYSTEM")

(export '(*break-readtable* *break-enable*
	  *tpl-evalhook* *tpl-prompt-hook*))

(defvar *quit-tag* (cons nil nil)) ;; This one was moved to the runtime C code. JCB
(defvar *quit-tags* nil)
(defvar *break-level* 0)		; nesting level of error loops
(defvar *break-env* nil)
(defvar *ihs-base* 0)
(defvar *ihs-top* (ihs-top))
(defvar *ihs-current* 0)
(defvar *frs-base* 0)
(defvar *frs-top* 0)
(defvar *tpl-continuable* t)
(defvar *tpl-prompt-hook* nil)
;(defvar *eof* (cons nil nil))
(defconstant *eof* :eof)

(defvar *last-error* nil)

(defvar *break-enable* t
  "MKCL specific.
When an error is signaled, control enters a break loop only if the value of
this variable is non-NIL.  The initial value is T, but MKCL automatically
rebinds this variable to NIL when control enters a break loop.")

(defvar *break-message* nil)

(defvar *break-readtable* nil)
(defvar *tpl-level* -1)			; nesting level of top-level loops
(defvar *step-level* 0)			; repeated from trace.lsp

(defvar *break-hidden-functions* '(error cerror apply funcall invoke-debugger))
(defvar *break-hidden-packages* (list #-mkcl-min (find-package 'system)))

;;(defconstant tpl-commands
(defparameter tpl-commands
   '(("Top level commands"
      ((:cf :compile-file) tpl-compile-command :string
       ":cf		Compile file"
       ":compile-file &string &rest files		[Top level command]~@
	:cf &string &rest files				[Abbreviation]~@
	~@
	Compile files.  With no arguments, uses values from latest :cf~@
	command.  File extensions are optional.~%")
      ((:exit :eof) mkcl:quit :eval

       ":exit   	Exit Lisp"
       ":exit &eval &key (exit-code 0) (verbose nil)	[Top level command]~@

	~@
	Exit Lisp without further confirmation.~%")
      ((:ld :load) tpl-load-command :string
       ":ld		Load file"
       ":load &string &rest files			[Top level command]~@
	:ld &string &rest files				[Abbreviation]~@
	~@
	Load files.  With no arguments, uses values from latest :ld~@
	or :cf command. File extensions are optional.~%")
      ((:step) tpl-step-command nil
       ":step		Single step form"
       ":step form					[Top level command]~@
	~@
	Evaluate form in single step mode.  While stepping, a new break~@
	level is invoked before every evaluation.  Extra commands are~@
	available at this time to control stepping and form evaluation.~%")
      ((:tr :trace) tpl-trace-command nil
       ":tr(ace)	Trace function"
       ":trace &rest functions				[Top level command]~@
	:tr &rest functions				[Abbreviation]~@
	~@
	Trace specified functions.  With no arguments, show currently~@
	traced functions.~@
	~@
	See also: :untrace.~%")
      ((:untr :untrace) tpl-untrace-command nil
       ":untr(ace)	Untrace function"
       ":untrace &rest functions			[Top level command]~@
	:untr &rest functions				[Abbreviation]~@
	~@
	Untrace specified functions.  With no arguments, untrace~@
	all functions.~@
	~@
	See also: :trace.~%")
      ((:wb :who-binds) tpl-who-binds-command nil
       ":w(ho-)b(inds)  Show function invocations currently binding variable"
       ":who-binds variable                             [Break command]~@
        :wb variable                                    [Abbreviation]~@
        ~@
        Show function invocations currently binding variable.~%")
      )
     ("Help commands"

      ((:ap :apropos) tpl-apropos-command nil
       ":ap(ropos) string		Apropos"

       ":apropos string &optional package		[Top level command]~@

	:ap string &optional package			[Abbrevation]~@

	~@
	Finds all available symbols whose print names contain string.~@

	If a non NIL package is specified, only symbols in that package are~@
	considered.~%")
      ((:doc :documentation) tpl-documentation-command nil
       ":doc(umentation) symbol 	Documentation"

       ":document symbol				[Top level command]~@

	:doc symbol					[Abbrevation]~@

	~@

	Displays documentation associated with symbol.~%")

      ((? :h :help) tpl-help-command nil

       ":h(elp) or ?			Help.  Type \":help help\" for details"

       ":help &optional topic				[Top level command]~@
	:h &optional topic				[Abbrevation]~@
      	~@
	Print information on specified topic.  With no arguments, print~@
	quick summery of top level commands.~@
	~@
	Help information for top level commands follows the documentation~@
	style found in \"Common Lisp, the Language\"; and, in general, the~@
	commands themselves follow the conventions of Common Lisp functions,~@
	with the exception that arguments are normally not evaluated.~@
	Those commands that do evaluate their arguments are indicated by the~@
	keyword &eval in their description.  A third class of commands~@
	treat their arguments as whitespace-separated, case-sensitive~@
	strings, requiring double quotes only when necessary.  This style~@
	of argument processing is indicated by the keyword &string.~@

	For example, the :load command accepts a list of file names:~@

	~@
	:load &string &rest files			[Top level Command]~@
	~@

	whereas :exit, which accepts an optional evaluated key argument, is~@

	~@

	:exit &eval &key (exit-code 0) (verbose nil)	[Top level Command]~%")

      )))

(defvar *tpl-commands* tpl-commands)

;;(defconstant break-commands
(defparameter break-commands
  '("Break commands"
     ((:q :quit) tpl-quit-command nil
       ":q(uit)		Return to some previous break level"
       ":quit &optional n				[Break command]~@
	:q &optional n					[Abbreviation]~@
	~@
	Without argument, return to top level;~@
	otherwise return to break level n.~%")
      ((:pop) (tpl-pop-command) :constant
       ":pop		Pop to previous break level"
       ":pop						[Break command]~@
	~@
	Pop to previous break level, or if already in top level,~@
	exit Lisp after confirmation.~%")
      ((:c :continue) continue nil
       ":c(ontinue)	Continue execution"
       ":continue					[Break command]~@
	:c						[Abbreviation]~@
	~@
	Continue execution.  Return from current break level to the caller.~@
	This command is only available when the break level is continuable~@
	(e.g., called from a correctable error or the function break).~%")
      ((:b :backtrace) tpl-backtrace nil
       ":b(acktrace)	Print backtrace"
       ":backtrace &optional n				[Break command]~@
	:b &optional n					[Abbreviation]~@
	~@
	Show function call history.  Only those functions called since~@
	the previous break level are shown.  In addition, functions compiled~@
	in-line or explicitly hidden are not displayed.  Without an argument,~@
	a concise backtrace is printed with the current function in upper~@
	case.  With integer argument n, the n functions above and including~@
	the current one are printed in a verbose format.~@
	~@
	See also: :function, :previous, :next.~%")
      ((:f :function) tpl-print-current nil
       ":f(unction)	Show current function"
       ":function					[Break command]~@
	:f						[Abbreviation]~@
	~@
	Show current function.  The current function is the implicit focus~@
	of attention for several other commands.  When it is an interpreted~@
 	function, its lexical environment is available for inspection and~@
	becomes the environment for evaluating user input forms.~@
	~@
	See also: :backtrace, :next, previous, :disassemble, :variables.~%")
      ((:p :previous) tpl-previous nil
       ":p(revious)	Go to previous function"
       ":previous &optional (n 1)			[Break command]~@
	:p &optional (n 1)				[Abbreviation]~@
	~@
	Move to the nth previous visible function in the backtrace.~@
 	It becomes the new current function.~@
	~@
	See also: :backtrace, :function, :go, :next.~%")
      ((:d :down) tpl-previous nil
       ":d(own)         Alias to :previous"
       ""
       )
      ((:n :next) tpl-next nil
       ":n(ext)		Go to next function"
       ":next &optional (n 1)				[Break command]~@
	:n &optional (n 1)				[Abbreviation]~@
	~@
	Move to the nth next visible function in the backtrace.  It becomes~@
	the new current function.~@
	~@
	See also: :backtrace, :function, :go, :previous.~%")
      ((:u :up) tpl-next nil
       ":u(p)           Alias to :next"
       ""
       )
      ((:g :go) tpl-go nil
       ":g(o)		Go to next function"
       ":go &optional (n 1)				[Break command]~@
	:g &optional (n 1)				[Abbreviation]~@
	~@
	Move to the function at IHS[i].~@
	See also: :backtrace, :function, :next, :previous.~%")
      ((:fs :forward-search) tpl-forward-search :string
       ":fs             Search forward for function"
       ":forward-search &string substring		[Break command]~@
	:fs &string substring				[Abbreviation]~@
	~@
	Search forward in the backtrace for function containing substring.~@
	The match is case insensitive.~@
	~@
	See also: :backtrace, :function, :next.~%")
      ((:bs :backward-search) tpl-backward-search :string
       ":bs             Search backward for function"
       ":backward-search &string substring		[Break command]~@
	:bs &string substring				[Abbreviation]~@
	~@
	Search backward in the backtrace for function containing substring.~@
	The match is case insensitive.~@
	~@
	See also: :backtrace, :function, :previous.~%")
      ((:disassemble) tpl-disassemble-command nil
       ":disassemble	Disassemble current function"
       ":disassemble					[Break command]~@
	:disassemble					[Abbreviation]~@
	~@
	Disassemble the current function. Currently, only interpreted functions~@
	can be disassembled.~%")
      ((:le :lambda-expression) tpl-lambda-expression-command nil
       ":l(ambda-)e(expression)	Show lisp code for current function"
       ":lambda-expression				[Break command]~@
	:le						[Abbreviation]~@
	~@
	Show the lisp code of the current function. Only works for interpreted~@
        functions.~%")
      ((:v :variables) tpl-variables-command nil
       ":v(ariables)	Show local variables, functions, blocks, and tags"
       ":variables &optional no-values			[Break command]~@
	:v &optional no-values				[Abbreviation]~@
	~@
	Show lexical variables, functions, block names, and tags local~@
	to the current function.  The current function must be interpreted.~@
	The values of local variables and functions are also shown,~@
	unless the argument is non-null.~%")
      ((:dv :dynamic-variables) tpl-dynamic-variables-command nil
       ":d(ynamic-)v(ariables)	Show dynamic variables bound by current function"
       ":dynamic-variables &optional no-values		[Break command]~@
	:dv &optional no-values				[Abbreviation]~@
	~@
	Show dynamic variables. The current function must be interpreted.~@
	The values of local dynamic variable bindings are also shown,~@
	unless the argument is non-null.~%")
      ((:hide) tpl-hide nil
       ":hide		Hide function"
       ":hide function					[Break command]~@
	~@
	Hide function.  A hidden function is not displayed in a backtrace.~@
	~@
	See also: :backtrace, :unhide, :hide-package.~%")
      ((:unhide) tpl-unhide nil
       ":unhide		Unhide function"
       ":unhide function				[Break command]~@
	~@
	Unhide function.  The specified function will be displayed in future~@
	backtraces, unless its home package is also hidden.~@
	~@
	See also: :backtrace, :hide, :unhide-package.~%")
      ((:hp :hide-package) tpl-hide-package nil
       ":hp		Hide package"
       ":hide-package package				[Break command]~@
	:hp package					[Abbreviation]~@
	~@
	Hide package.  Functions in a hidden package are not displayed~@
	in a backtrace.~@
	~@
	See also: :backtrace, :unhide-package.~%")
      ((:unhp :unhide-package) tpl-unhide-package nil
       ":unhp		Unhide package"
       ":unhide-package package				[Break command]~@
	:unhp package					[Abbreviation]~@
	~@
	Unhide package.  Functions in the specified package will be displayed~@
	in future backtraces, unless they are individually hidden.~@
	~@
	See also: :backtrace, :hide-package, :hide, :unhide.~%")
      ((:unhide-all) tpl-unhide-all nil
       ":unhide-all     Unhide all variables and packages"
       ":unhide-all					[Break command]~@
	~@
	Unhide all variables and packages.  All functions will be displayed~@
	in future backtraces.~@
	~@
	See also: :hide, :unhide, :hide-package, :unhide-package.~%")
      ((:bds :binding-stack) tpl-bds-command nil
       ":bds            Show binding stack"
       ":binding-stack &optional variable		[Break command]~@
	:bds &optional variable				[Abbreviation]~@
	~@
	Without an argument, show the entire binding stack since the previous~@
	break level.  With a variable name, print nothing, but return the~@
	value of the given variable on the binding stack.~%")
      ((:frs :frame-stack) tpl-frs-command nil
       ":frs            Show frame stack"
       ""
       )
      ((:m :message) tpl-print-message nil
       ":m(essage)      Show error message"
       ":message					[Break command]~@
	:m						[Abbreviation]~@
	~@
	Show current error message.~%")
      ((:hs :help-stack) tpl-help-stack-command nil
       ":hs		Help stack"
       ":help-stack					[Break command]~@
	:hs						[Abbrevation]~@
	~@
	Lists the functions to access the LISP system stacks.~%")
      ((:i :inspect) tpl-inspect-command nil
       ":i(nspect)      Inspect value of local variable"
       ":inspect var-name                               [Break command]~@
        :i var-name                                     [Abbreviation]~@
        ~@
        Inspect value of local variable named by var-name. Argument~@
        var-name can be a string or a symbol whose name string will~@
        then be used regardless of of the symbol's package.~@
        ~@
        See also: :variables.~%")

      ((:r :restarts) tpl-help-restarts-command nil
       ":r(estarts)     Display available restarts"
       ":restarts                                       [Break command]~@
        :r                                              [Abbreviation]~@
        ~@
        Display available restarts.~%")

      ((:s :switch) tpl-switch-command nil
       ":s(witch)       Switch to next thread to debug"
       ":switch debuggee                                [Break command]~@
        :s debuggee                                     [Abbreviation]~@
        ~@
        Switch to next thread in need to debugger attention. Argument~@
        debuggee, when provided, must be an integer indicating the rank~@
        of the thread in the debugger waiting list.~%")
      ((:w :waiting) tpl-waiting-command nil
       ":w(aiting)      Display debugger's waiting list"
       ":waiting                                        [Break command]~@
        :w                                              [Abbreviation]~@
        ~@
        Display debugger's waiting list.~%")
      )
  )

(defvar *lisp-initialized* nil)

(defun print-copyright (&optional (stream t))
  (format stream "~%Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya~@
                     Copyright (C) 1993 Giuseppe Attardi~@
                     Copyright (C) 2000 Juan J. Garcia-Ripoll~@

                     Copyright (C) 2010-2013 Jean-Claude Beaudoin~%~@

                     ManKai Common Lisp (MKCL) is free software,~@
                     and you are welcome to redistribute and/or~@
                     modify it under the terms of the GNU LGPL.~@
                     See file 'Copyright' in the source code for details.~%")
  )

(defvar *display-banner* t)

(defun top-level (&aux (*display-banner* *display-banner*))
  "Args: ()
MKCL specific.
The top-level loop of MKCL. It is called by default when MKCL is invoked."
  (catch *quit-tag*
    (let* ((*debugger-hook* nil)
	   + ++ +++ - * ** *** / // ///)

      (in-package "CL-USER")

      (unless *lisp-initialized*
	(let ((*break-enable* nil))
	  ;; process command arguments
	  (process-command-args))
	(when *display-banner*
	  (format t "~&~%This is ManKai Common Lisp ~A~%" (mkcl-version))
	  (print-copyright)
	  )
	(setq *lisp-initialized* t))

      (let ((*break-enable* t)
	    (*tpl-level* -1))
	(grab-console)
	(unwind-protect (interactive-loop :quiet (not *display-banner*)) ;;(tpl)
	  (release-console))))))

(defvar *allow-recursive-debug* nil)
(defvar *debug-status* nil)

(defvar *console-lock* (mt:make-lock :name "Console lock" :recursive t))
#-windows
(defvar *console-available* (mt:make-condition-variable))
(defvar *console-owner* nil)

(defun grab-console (&key (wait t))
;;  (mt:with-lock (*console-lock*)
  (let ((locked nil))
    (unwind-protect
	(progn
	  (mt:without-interrupts
	   (mt:get-lock *console-lock* wait)
	   (setq locked t))
	  (if *console-owner*
	      (unless (eq *console-owner* mt:*thread*)
		;;#-windows (mt:condition-wait *console-available* *console-lock*)
		#-windows (do () ((mt:condition-wait *console-available* *console-lock* 0.1)) (sleep 0.4)) ;; 0.1 seconds wait timeout
		#+:windows (do () 
			       ((null *console-owner*))
			       (mt:without-interrupts
				(mt:giveup-lock *console-lock*)
				(setq locked nil))
			       (sleep 1)
			       (mt:without-interrupts
				(mt:get-lock *console-lock* t)
				(setq locked t)))
		(setq *console-owner* mt:*thread*)
		)
	    (setq *console-owner* mt:*thread*)
	    )
	  )
      (mt:without-interrupts
       (when locked
	 (mt:giveup-lock *console-lock*)))
      )
    )
  )

(defun release-console ()
  (mt:with-lock (*console-lock*)
    (setq *console-owner* nil)
    #-windows (mt:condition-signal *console-available*)
    )
  )

(defun terminal-interrupt (correctablep)
  (let ((*break-enable* t))
    (if correctablep
      (cerror "Continues execution." 'mkcl:interactive-interrupt)
      (error "Console interrupt -- cannot continue."))))

(defun terminal-interrupt-interactive ()
  (terminal-interrupt t))

(defun sigint-handler (signo)
  (declare (ignore signo))
  (do () (*console-owner*)
      (grab-console :wait nil))
  (if (eq *console-owner* mt:*thread*)
      (progn
	(unwind-protect (terminal-interrupt t) (release-console))
	)
    (progn
      (handler-case
       (mt:interrupt-thread *console-owner* 'terminal-interrupt-interactive)
       (mt:thread-sleeping (cond)
	 (format t "~&Interruption failed (sleeping): ~A~%" cond) (finish-output))
       (mt:interrupt-refused (cond)
	 (format t "~&Interruption failed (refused): ~A~%" cond) (finish-output))
       (condition (cond)
	 (format t "~&Interruption failed (unknown): ~A~%" cond) (finish-output))
       )
      )
    ))

(defun sighup-handler (signo)
  (format t "~&*** MKCL: Received signal SIGHUP (~D). Quitting! ***~%" signo)
  (finish-output)
  (mkcl:quit :exit-code (+ #x80 signo))
  )
  
(defun sigterm-handler (signo)
  (format t "~&***  MKCL: Received signal SIGTERM (~D). Quitting! ***~%" signo)
  (finish-output)
  (mkcl:quit :exit-code (+ #x80 signo))
  )
  
(defun terminal-signal-handler (signo)
  (format t "~&***  MKCL: Received a terminal signal (~D). Quitting! ***~%" signo)
  (finish-output)
  (mkcl:quit :exit-code (+ #x80 signo))
  )
  

(defun interactive-loop  ;; formerly known as "tpl"
  (&key ((:commands *tpl-commands*) tpl-commands)
	((:prompt-hook *tpl-prompt-hook*) *tpl-prompt-hook*)
	(broken-at nil)
	(quiet nil))
  (let* ((*ihs-base* *ihs-top*)
	 (*ihs-top* (if broken-at (ihs-search t broken-at) (ihs-top)))
	 (*ihs-current* (if broken-at (ihs-prev *ihs-top*) *ihs-top*))
	 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
	 (*frs-top* (frs-top))
	 (*quit-tags* (cons *quit-tag* *quit-tags*))
	 (*quit-tag* *quit-tags*)	; any unique new value
	 (*tpl-level* (1+ *tpl-level*))

	 (break-level *break-level*))

    (set-current-ihs)
    (unless quiet

      (format t "~%Type :h for Help.")

      (break-where))

    (macrolet ((read-eval-print (break-level)
		`(block read-eval-print
                   (handler-bind 
                    ((condition
                      (lambda (condition)
                        (cond ((subtypep (type-of condition) 'warning)
                               ;; We let warnings pass by, this way "warn" does the work.
                               )
                              ((< ,break-level 1)
                               ;; Toplevel should enter the debugger on any condition.
                               )
                              (*allow-recursive-debug*
                               ;; We are told to let the debugger handle this.
                               )
                              (t
                               (format t "~&Debugger received error: ~A~%~

                                         Error flushed.~%" condition)

                               (clear-input)
                               (return-from read-eval-print t) ;; go back into the debugger loop.
                               )
                              )
                        )))
                    
                    (tpl-prompt)
                    (setq - (tpl-read))
                    (let ((values (multiple-value-list (eval-in-env - (decode-ihs-env *break-env*)))))
                      (setq /// // // / / values *** ** ** * * (car /))
                      (tpl-print values))))))

	  (loop
	   (setq +++ ++ ++ + + -)
	   (when
	       (catch *quit-tag*
		 (if (zerop break-level)
		     #+(or)
		     (with-simple-restart 
		      (restart-toplevel "Go back to Top-Level REPL.")

		      (read-eval-print break-level))
		     (restart-case (read-eval-print break-level)

		       (restart-toplevel ()
			 :report (lambda (stream) (princ "Go back to Top-Level REPL." stream))
			 (values nil t)))
		   #+(or)
		   (with-simple-restart
		    (restart-debugger "Go back to debugger level ~D." break-level)

		    (read-eval-print break-level))
		   (restart-case (read-eval-print break-level)

		     (restart-debugger ()
		       :report (lambda (stream)
				 (princ "Go back to debugger level " stream)
				 (princ break-level stream)
				 (write-char #\. stream))
		       (values nil t)))
		   )
		 nil)
	     (break-where))))))

(defun tpl-prompt ()
  (typecase *tpl-prompt-hook*
    (string (format t *tpl-prompt-hook*))
    (function (funcall *tpl-prompt-hook*))
    (t (fresh-line)
       (format t "~A~V,,,'>A "
	       (if (eq *package* (find-package 'user))
		   ""
		 (package-name *package*))
	       (- *tpl-level* *step-level* -1)
	       ""))))

(defun tpl-read (&aux (*read-suppress* nil))
  (finish-output)
  (loop
    (case (peek-char nil *standard-input* nil :EOF)
      ((#\))
       (warn "Ignoring an unmatched right parenthesis.")
       (read-char))
      ((#\space #\tab)
       (read-char))
      ((#\newline #\return)
       (read-char)
       ;; avoid repeating prompt on successive empty lines:
       (let ((command (tpl-make-command :newline "")))
	 (when command (return command))))
      (:EOF
       (terpri)
       #+unix (return (tpl-make-command :EOF ""))
       ;; On MS-Windows we cannot trust the :EOF indicator
       ;; since it could be generated on Ctrl+C and Ctrl+Break!
       ;; We are forced to simply ignore it! JCB
       )

      #+windows
      (#\Sub ;; Ctrl+Z.
       ;; On Unix it used to be #\Eot (aka Ctrl+D) but that interferred with a bug workaround. JCB

       ;; This is as a substitute for the problem mentionned just above. JCB
       (return (tpl-make-command :EOF ""))
       )
      (#\:
       (return (tpl-make-command (read-preserving-whitespace)
				 (read-line))))
      (#\?
       (read-char)
       (case (peek-char nil *standard-input* nil :EOF)
	 ((#\space #\tab #\newline #\return :EOF)
	  (return (tpl-make-command :HELP (read-line))))
	 (t
	  (unread-char #\?)
	  (return (read-preserving-whitespace)))))
      ;; We use READ-PRESERVING-WHITESPACE because with READ, if an
      ;; error happens within the reader, and we perform a ":C" or
      ;; (CONTINUE), the reader will wait for an inexistent #\Newline.
      (t
       (return (read))))))

(defvar *debug-tpl-commands* nil)

(defun harden-command (cmd-form)
  `(block 
    tpl-command
    (handler-bind 
     ((error (lambda (condition)
	       (unless *debug-tpl-commands*
		 (format t "~&Command aborted.~%Received condition: ~A" condition)
		 (clear-input)

		 (return-from tpl-command nil)))))
     ,cmd-form)))