;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: COMMON-LISP -*-
;;; Copyright©2003 Peder O. Klingenberg <peder@klingenberg.no>.
;;;
;;; Permission is hereby granted to anyone to use, (re-)distribute
;;; and modify this code for any purpose.
;;;
;;; This code comes WITH NO WARRANTY; without even the implied warranty
;;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  There - I
;;; said it.
;;;
;;; $Id: commands.lisp,v 1.2 2003/09/17 14:51:54 pok Exp $

;;; This code fleshes out the hooks in CMUCL's REPL to allow short non-lisp
;;; commands.  Most of the code is pilfered from CMUCL's own debugger, which
;;; already does this, but in a slightly different manner.

(in-package #:common-lisp)

(defvar *commands* nil "An alist of commands on the form (name . function).")

(defun commandp (form)
  "Determines if a form is a command (or prefix of a set of commands).
Returns NIL, the function implementing the command, or a list of
command names if more than one match.  Called from the CMUCL REPL."
  (if (and (symbolp form)
	   (eq (symbol-package form)
	       #.(find-package "KEYWORD")))
      (let* ((name (symbol-name form))
	     (len (length name))
	     (res nil))
	(declare (simple-string name)
		 (fixnum len)
		 (list res))
	;;
	;; Find matching commands, punting if exact match.
	(flet ((match-command (ele)
	         (let* ((str (car ele))
			(str-len (length str)))
		   (declare (simple-string str)
			    (fixnum str-len))
		   (cond ((< str-len len))
			 ((= str-len len)
			  (when (string= name str :end1 len :end2 len)
			    (return-from commandp (cdr ele))))
			 ((string= name str :end1 len :end2 len)
			  (push ele res))))))
	  (mapc #'match-command *commands*))
	;;
	;; Return the right value.
	(cond ((not res) nil)
	      ((= (length res) 1)
	       (cdar res))
	      (t ;Just return the names.
	       (do ((cmds res (cdr cmds)))
		   ((not cmds) res)
		 (setf (car cmds) (caar cmds))))))))

(defun invoke-command-interactive (form)
  "Executes a command or complains about ambiguity.
Called from the CMUCL top-level REPL."
  (let ((cmd (commandp form)))
    (assert (not (null cmd)))
    (cond
      ((consp cmd)
       (format t "~&Ambigous command: ~S.~%" form)
       (dolist (ele cmd)
	 (format t "   ~A~%" ele)))
      (t
       (funcall cmd)))))

(in-package #:extensions)

(defmacro def-command (name &rest body)
  "Interface to *COMMANDS*.  The rest of the line (if any)
is read into a string available as COMMAND-ARG in the body."
  (let ((name (typecase name
		(string (symbol-name (read-from-string name)))
		(symbol (symbol-name name))
		(t name))))
    (let ((fun-name (intern (concatenate 'simple-string name "-COMMAND"))))
      `(progn
	(when (assoc ,name cl::*commands* :test #'string=)
	  (setf cl::*commands*
		(remove ,name cl::*commands* :key #'car :test #'string=)))
	(defun ,fun-name ()
	  (let ((command-arg (when (listen)
			       (read-line))))
	    (declare (ignorable command-arg))
	    ,@body))
	(push (cons ,name #',fun-name) cl::*commands*)
	',fun-name))))

(defmacro def-command-alias (new-name existing-name)
  "Interface to *COMMANDS*.  Defines a new command to be a copy
of another command at the time of definition."
  (let ((new-name (typecase new-name
		    (string (symbol-name (read-from-string new-name)))
		    (symbol (symbol-name new-name))
		    (t new-name)))
	(existing-name (typecase existing-name
			 (string (symbol-name (read-from-string existing-name)))
			 (symbol (symbol-name existing-name))
			 (t existing-name))))
    `(progn
      (let ((pair (assoc ,existing-name cl::*commands* :test #'string=)))
	(unless pair (error "Unknown command name -- ~S" ,existing-name))
	(push (cons ,new-name (cdr pair)) cl::*commands*))
      ,new-name)))

(export '(def-command def-command-alias command-arg))

;;; Standard command definitions:

(def-command #:quit (quit))
(def-command-alias #:exit quit)

(def-command #:load
  (when command-arg
    (when (eql (char command-arg 0) #\")
      (setf command-arg (read-from-string command-arg)))
    (load command-arg)))
(def-command-alias #:ld #:load)

(def-command #:cd
  (when command-arg
    (when (eql (char command-arg 0) #\")
      (setf command-arg (read-from-string command-arg)))
    (setf (default-directory) command-arg))
  (default-directory))

(def-command #:pwd (default-directory))

(def-command #:compile-file
  (when command-arg
    (when (eql (char command-arg 0) #\")
      (setf command-arg (read-from-string command-arg)))
    (compile-file command-arg)))
(def-command-alias #:cf #:compile-file)

(def-command #:package
  (when command-arg
    (let* ((pkg (read-from-string command-arg))
	   (pkgname (cond
		      ((symbolp pkg) (symbol-name pkg))
		      ((stringp pkg) (symbol-name (read-from-string pkg)))
		      (t pkg))))
      (cl::%in-package pkgname)))
  cl::*package*)
(def-command-alias #:pkg #:package)

(def-command #:printhash
    (let ((hash (eval (read-from-string command-arg))))
      (if (typep hash 'hash-table)
	  (maphash #'(lambda (k v)
		       (format t "~&~s: ~s~%" k v))
		   hash)
	  (format t "~&ERROR: ~s is not a HASH-TABLE~%" hash)))
  (values))

(def-command-alias #:ph #:printhash)