subr.lisp

   1 ;;; subr.lice --- basic lisp subroutines for Emacs
   2
   3 (in-package "LICE")
   4
   5 ;;; Argument types
   6
   7 (defun interactive (&rest prompts)
   8   "Read input from the minibuffer and return it in a list."
   9   (loop for p in prompts
  10         collect (read-from-minibuffer p)))
  11
  12 (defvar *extended-command-history* nil)
  13
  14 (defun read-command (prompt)
  15   "Read the name of a command and return as a symbol.
  16 Prompt with prompt.  By default, return default-value."
  17   (let (cmds)
  18     (maphash (lambda (k v)
  19                (declare (ignore v))
  20                (push k cmds))
  21              *commands*)
  22     (dformat +debug-v+ "commands: ~s~%" cmds)
  23     ;; Sadly, a cheap hack
  24     (find (completing-read prompt cmds :history '*extended-command-history*)
  25           cmds :test #'string-equal :key #'symbol-name)))
  26
  27 (defun read-buffer (prompt &optional def require-match)
  28   "Read the name of a buffer and return as a string.
  29 Prompt with prompt.
  30 Optional second arg def is value to return if user enters an empty line.
  31 *If optional third arg require-match is non-nil,
  32 * only existing buffer names are allowed."
  33   (declare (ignore require-match))
  34   (let* ((bufs (mapcar (lambda (b)
  35                          (cons (buffer-name b) b))
  36                        *buffer-list*))
  37          (b (completing-read (if def
  38                                  (format nil "~a(default ~a) " prompt def)
  39                                prompt)
  40                              bufs)))
  41     (if (zerop (length b))
  42         def
  43       b)))
  44
  45 (defun read-file-name (prompt &key dir default-filename mustmatch initial predicate)
  46   "Read file name, prompting with prompt and completing in directory dir.
  47 Value is not expanded---you must call `expand-file-name' yourself.
  48 Default name to default-filename if user exits the minibuffer with
  49 the same non-empty string that was inserted by this function.
  50  (If default-filename is omitted, the visited file name is used,
  51   except that if initial is specified, that combined with dir is used.)
  52 If the user exits with an empty minibuffer, this function returns
  53 an empty string.  (This can only happen if the user erased the
  54 pre-inserted contents or if `insert-default-directory' is nil.)
  55 Fourth arg mustmatch non-nil means require existing file's name.
  56  Non-nil and non-t means also require confirmation after completion.
  57 Fifth arg initial specifies text to start with.
  58 If optional sixth arg predicate is non-nil, possible completions and
  59 the resulting file name must satisfy (funcall predicate NAME).
  60 dir should be an absolute directory name.  It defaults to the value of
  61 `:default-directory'.
  62
  63 If this command was invoked with the mouse, use a file dialog box if
  64 `use-dialog-box' is non-nil, and the window system or X toolkit in use
  65 provides a file dialog box.
  66
  67 See also `read-file-name-completion-ignore-case'
  68 and `read-file-name-function'."
  69   (declare (ignore predicate initial mustmatch default-filename dir))
  70   (completing-read prompt #'file-completions :initial-input (princ-to-string *default-directory*)))
  71
  72 (defun read-string (prompt &optional initial-input history default-value)
  73   "Read a string from the minibuffer, prompting with string prompt.
  74 If non-nil, second arg initial-input is a string to insert before reading.
  75   This argument has been superseded by default-value and should normally
  76   be nil in new code.  It behaves as in `read-from-minibuffer'.  See the
  77   documentation string of that function for details.
  78 The third arg history, if non-nil, specifies a history list
  79   and optionally the initial position in the list.
  80 See `read-from-minibuffer' for details of history argument.
  81 Fourth arg default-value is the default value.  If non-nil, it is used
  82  for history commands, and as the value to return if the user enters
  83  the empty string.
  84 **Fifth arg inherit-input-method, if non-nil, means the minibuffer inherits
  85  the current input method and the setting of `enable-multibyte-characters'."
  86   (read-from-minibuffer prompt :initial-contents initial-input :history history :default-value default-value))
  87
  88 (defun region-limit (beginningp)
  89   "Return the start or end position of the region.
  90 BEGINNINGP non-zero means return the start.
  91 If there is no region active, signal an error."
  92   (if beginningp
  93       (min (point) (mark))
  94       (max (point) (mark))))
  95
  96 (defun region-beginning ()
  97   "Return position of beginning of region, as an integer."
  98   (region-limit t))
  99
 100 (defun region-end ()
 101   "Return position of end of region, as an integer."
 102   (region-limit nil))
 103
 104 (defun add-command-arg-type (type fn)
 105   "TYPE is a symbol. Add it to the hash table of command types and link it to FN, a function or function symbol."
 106   (setf (gethash type *command-arg-type-hash*) fn))
 107
 108 (defun init-command-arg-types ()
 109   "populate the hash table with some defaults"
 110   ;; Reset the hash table. FIXME: should we do this?
 111   (setf *command-arg-type-hash* (make-hash-table))
 112   (add-command-arg-type :buffer 'read-buffer)
 113   (add-command-arg-type :file 'read-file-name)
 114   (add-command-arg-type :string 'read-from-minibuffer)
 115   (add-command-arg-type :command 'read-command)
 116   (add-command-arg-type :prefix 'prefix-arg)
 117   (add-command-arg-type :raw-prefix 'raw-prefix-arg)
 118   (add-command-arg-type :region-beginning 'region-beginning)
 119   (add-command-arg-type :region-end 'region-end))
 120
 121 (defun get-buffer-window-list (buffer &optional minibuf frame)
 122   "Return list of all windows displaying BUFFER, or nil if none.
 123 BUFFER can be a buffer or a buffer name.
 124 See `walk-windows' for the meaning of MINIBUF and FRAME."
 125   (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows)
 126     (mapc (lambda (window)
 127             (if (eq (window-buffer window) buffer)
 128                 (push window windows)))
 129           (frame-window-list frame minibuf))
 130     windows))
 131
 132 ;; FIXME: this isn't complete.
 133 (defmacro defalias (from-symbol to-symbol)
 134 "Set symbol's function definition to definition, and return definition."
 135   `(define-symbol-macro ,from-symbol ,to-symbol))
 136
 137 (defun intern-soft (name &optional (package *package*))
 138   (find-symbol name package))
 139
 140 ;;; reading from the buffer
 141
 142 (defun read-from-buffer (&aux (buffer (current-buffer)))
 143   "Read 1 sexp from the buffer at the current point, moving the point to the end of what was read"
 144   (when (< (buffer-char-to-aref buffer (point buffer))
 145            (buffer-gap-start buffer))
 146     (gap-move-to-point buffer))
 147   (multiple-value-bind (obj pos)
 148       (read-from-string (buffer-data buffer) t nil
 149                         :start (buffer-char-to-aref buffer (point buffer)))
 150     (set-point (buffer-aref-to-char buffer pos))
 151     obj))
 152
 153 (defcommand eval-region ((start end &optional print-flag (read-function 'read-from-string))
 154                          :region-beginning :region-end)
 155   "Execute the region as Lisp code.
 156 When called from programs, expects two arguments,
 157 giving starting and ending indices in the current buffer
 158 of the text to be executed.
 159 Programs can pass third argument PRINTFLAG which controls output:
 160 A value of nil means discard it; anything else is stream for printing it.
 161 Also the fourth argument READ-FUNCTION, if non-nil, is used
 162 instead of `read' to read each expression.  It gets one argument
 163 which is the input stream for reading characters.
 164
 165 This function does not move point."
 166   (let* ((stdout (make-string-output-stream))
 167          (*standard-output* stdout)
 168          (*error-output* stdout)
 169          (*debug-io* stdout)
 170          (string (buffer-substring-no-properties start end))
 171          (pos 0)
 172          last obj)
 173     (loop
 174        (setf last obj)
 175        (multiple-value-setq (obj pos) (funcall read-function string nil string :start pos))
 176        (when (eq obj string)
 177          (cond ((eq print-flag t)
 178                 (message "~s" last)))
 179          (return-from eval-region last)))))
 180
 181 (defun sit-for (seconds &optional nodisp)
 182   "Perform redisplay, then wait for seconds seconds or until input is available.
 183 seconds may be a floating-point value, meaning that you can wait for a
 184 fraction of a second.
 185  (Not all operating systems support waiting for a fraction of a second.)
 186 Optional arg nodisp non-nil means don't redisplay, just wait for input.
 187 Redisplay is preempted as always if input arrives, and does not happen
 188 if input is available before it starts.
 189 Value is t if waited the full time with no input arriving."
 190   (declare (ignore seconds nodisp))
 191   ;; FIXME: actually sleep
 192   (frame-render (selected-frame)))
 193
 194 (provide :lice-0.1/subr)