From: tailor Date: Fri, 24 Aug 2007 22:41:19 +0000 (+0000) Subject: [lice @ shit loads of stuff] X-Git-Url: https://repo.or.cz/w/lice.git/commitdiff_plain/39add37b73bfa86fb6fd5dab1ba6a804cd7b9185 [lice @ shit loads of stuff] --- diff --git a/src/Makefile.in b/src/Makefile.in index d924b72..0aa10f1 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -15,5 +15,8 @@ all: lice lice: $(FILES) $(LISP) $(LISP_OPTS) +etags: TAGS + etags `find . -name \*.lisp` # we could use FILES but it just isn't always up to date + clean: rm -f *.fasl *.fas *.lib lice diff --git a/src/callint.lisp b/src/callint.lisp new file mode 100644 index 0000000..d40ce24 --- /dev/null +++ b/src/callint.lisp @@ -0,0 +1,82 @@ +;;; Call a Lisp function interactively. + +(defvar *prefix-arg* nil + "The value of the prefix argument for the next editing command. +It may be a number, or the symbol `-' for just a minus sign as arg, +or a list whose car is a number for just one or more C-u's +or nil if no argument has been specified. + +You cannot examine this variable to find the argument for this command +since it has been set to nil by the time you can look. +Instead, you should use the variable `current-prefix-arg', although +normally commands can get this prefix argument with (interactive \"P\").") + +(defvar *last-prefix-arg* nil +"The value of the prefix argument for the previous editing command. +See `prefix-arg' for the meaning of the value.") + +(defvar *current-prefix-arg* nil + "The value of the prefix argument for this editing command. +It may be a number, or the symbol `-' for just a minus sign as arg, +or a list whose car is a number for just one or more C-u's +or nil if no argument has been specified. +This is what `(interactive \"P\")' returns.") + +(defvar *command-history* nil + "List of recent commands that read arguments from terminal. +Each command is represented as a form to evaluate.") + +(defun call-interactively (function &optional record-flag (keys *this-command-keys*)) + "Call FUNCTION, reading args according to its interactive calling specs. +Return the value FUNCTION returns. +The function contains a specification of how to do the argument reading. +In the case of user-defined functions, this is specified by placing a call +to the function `interactive' at the top level of the function body. +See `interactive'. + +Optional second arg RECORD-FLAG non-nil +means unconditionally put this command in the command-history. +Otherwise, this is done only if an arg is read using the minibuffer. + +Optional third arg KEYS, if given, specifies the sequence of events to +supply, as a vector, if the command inquires which events were used to +invoke it. If KEYS is omitted or nil, the return value of +`*this-command-keys-vector*' is used." + (setf function (lookup-command function)) + (check-type function command) + + (let ((args (mapcar (lambda (a) + (if (listp a) + (apply (gethash (first a) *command-arg-type-hash*) (cdr a)) + (funcall (gethash a *command-arg-type-hash*)))) + (command-args function)))) + ;; XXX: Is this a sick hack? We need to reset the + ;; prefix-arg at the right time. After the command + ;; is executed we can't because the universal + ;; argument code sets the prefix-arg for the next + ;; command. The Right spot seems to be to reset it + ;; once a command is about to be executed, and + ;; after the prefix arg has been gathered to be + ;; used in the command. Which is right here. + (setf *prefix-arg* nil) + ;; Note that we use the actual function. If the + ;; function is redefined, the command will + ;; continue to be defined and will call the + ;; function declared above, not the redefined one. + (apply (command-fn function) args))) + +(defun prefix-numeric-value (prefix) + "Return numeric meaning of raw prefix argument RAW. +A raw prefix argument is what you get from :raw-prefix. +Its numeric meaning is what you would get from :prefix." + ;; TODO + (cond ((null prefix) + 1) + ((eq prefix '-) + -1) + ((and (consp prefix) + (integerp (car prefix))) + (car prefix)) + ((integerp prefix) + prefix) + (t 1))) diff --git a/src/casefiddle.lisp b/src/casefiddle.lisp index deedaab..f4e2c12 100644 --- a/src/casefiddle.lisp +++ b/src/casefiddle.lisp @@ -32,27 +32,27 @@ The argument object is not altered--the value is a copy." (defun upcase-region (beg end) (declare (ignore beg end)) - (error "Unimplemented")) + (error "Unimplemented upcase-region")) (setf (get 'upcase-region 'disabled) t) (defun downcase-region () - (error "Unimplemented")) + (error "Unimplemented downcase-region")) (setf (get 'downcase-region 'disabled) t) (defun capitalize-region () - (error "Unimplemented")) + (error "Unimplemented capitalize-region")) (defun upcase-initials-region () - (error "Unimplemented")) + (error "Unimplemented upcase-initials-region")) (defun upcase-word () - (error "Unimplemented")) + (error "Unimplemented upcase-word")) (defun downcase-word () - (error "Unimplemented")) + (error "Unimplemented downcase-word")) (defun capitalize-word () - (error "Unimplemented")) + (error "Unimplemented apitalize-word")) ;;; Key bindings diff --git a/src/charset.lisp b/src/charset.lisp index 8567701..f68cdc2 100644 --- a/src/charset.lisp +++ b/src/charset.lisp @@ -1,67 +1,64 @@ (in-package "LICE") (defun define-charset () - (error "unimplemented")) + (error "unimplemented define-charset")) (defun generic-character-list () - (error "unimplemented")) + (error "unimplemented generic-character-list")) (defun get-unused-iso-final-char () - (error "unimplemented")) + (error "unimplemented get-unused-iso-final-char")) (defun declare-equiv-charset () - (error "unimplemented")) + (error "unimplemented declare-equiv-charset")) (defun find-charset-region () - (error "unimplemented")) + (error "unimplemented find-charset-region")) (defun find-charset-string () - (error "unimplemented")) + (error "unimplemented find-charset-string")) (defun make-char-internal () - (error "unimplemented")) + (error "unimplemented make-char-internal")) (defun split-char () - (error "unimplemented")) + (error "unimplemented split-char")) (defun char-charset () - (error "unimplemented")) + (error "unimplemented char-charset")) (defun charset-after (&optional (pos (pt))) "Return charset of a character in the current buffer at position POS. If POS is nil, it defauls to the current point. If POS is out of range, the value is nil." - (error "unimplemented")) + (error "unimplemented charset-after")) (defun iso-charset () - (error "unimplemented")) + (error "unimplemented iso-charset")) (defun char-valid-p () - (error "unimplemented")) + (error "unimplemented char-valid-p")) (defun unibyte-char-to-multibyte () - (error "unimplemented")) + (error "unimplemented unibyte-char-to-multibyte")) (defun multibyte-char-to-unibyte () - (error "unimplemented")) + (error "unimplemented multibyte-char-to-unibyte")) (defun char-bytes () - (error "unimplemented")) + (error "unimplemented char-bytes")) (defun char-width () - (error "unimplemented")) + (error "unimplemented char-width")) (defun string-width () - (error "unimplemented")) + (error "unimplemented" string-width)) (defun char-direction () - (error "unimplemented")) + (error "unimplemented char-direction")) ;; (defun string () -;; (error "unimplemented")) +;; (error (format nil "unimplemented ~a")) (defun setup-special-charsets () - (error "unimplemented")) - - - + (error "unimplemented setup-special-charsets")) diff --git a/src/cmds.lisp b/src/cmds.lisp index cfea3c6..33b343e 100644 --- a/src/cmds.lisp +++ b/src/cmds.lisp @@ -73,10 +73,10 @@ With positive n, a non-empty line at the end counts as one line (+ n flines)))))) (defun beginning_of_line () - (error "unimplemented")) + (error "unimplemented beginning_of_line")) (defun end_of_line () - (error "unimplemented")) + (error "unimplemented end_of_line")) (defcommand delete-char () "Delete the following N characters." diff --git a/src/commands.lisp b/src/commands.lisp index 021a3c2..bd10c3c 100644 --- a/src/commands.lisp +++ b/src/commands.lisp @@ -2,17 +2,6 @@ (in-package "LICE") -(defvar *prefix-arg* nil - "The value of the prefix argument for the next editing command. -It may be a number, or the symbol `-' for just a minus sign as arg, -or a list whose car is a number for just one or more C-u's -or nil if no argument has been specified. - -You cannot examine this variable to find the argument for this command -since it has been set to nil by the time you can look. -Instead, you should use the variable `current-prefix-arg', although -normally commands can get this prefix argument with (interactive \"P\").") - (defclass command () ((name :type symbol :initarg :name :accessor command-name) (args :type list :initarg :args :accessor command-args) @@ -35,26 +24,7 @@ normally commands can get this prefix argument with (interactive \"P\").") :name ',name :args ',interactive-args :doc ,(when (typep (first body) 'string) (first body)) - :fn (lambda () - (let ((,tmp (list ,@(mapcar (lambda (a) - (if (listp a) - `(funcall (gethash ,(first a) *command-arg-type-hash*) ,@(cdr a)) - `(funcall (gethash ,a *command-arg-type-hash*)))) - interactive-args)))) - ;; XXX: Is this a sick hack? We need to reset the - ;; prefix-arg at the right time. After the command - ;; is executed we can't because the universal - ;; argument code sets the prefix-arg for the next - ;; command. The Right spot seems to be to reset it - ;; once a command is about to be executed, and - ;; after the prefix arg has been gathered to be - ;; used in the command. Which is right here. - (setf *prefix-arg* nil) - ;; Note that we use the actual function. If the - ;; function is redefined, the command will - ;; continue to be defined and will call the - ;; function declared above, not the redefined one. - (apply #',name ,tmp)))))))) + :fn #',name))))) (defgeneric lookup-command (name) (:documentation "lookup the command named NAME.")) @@ -67,11 +37,6 @@ normally commands can get this prefix argument with (interactive \"P\").") ;; symbols. (gethash (intern (string-upcase name) "KEYWORD") *commands*)) -(defun call-command (name &rest args) - "Use this command to call an interactive command from a lisp program." - (let ((cmd (lookup-command name))) - (apply (command-fn cmd) args))) - (defvar *command-arg-type-hash* (make-hash-table) "A hash table of symbols. each symbol is an interactive argument type whose value is a function that is called to gather input from the diff --git a/src/custom.lisp b/src/custom.lisp index ede2e85..23aa9c5 100644 --- a/src/custom.lisp +++ b/src/custom.lisp @@ -11,7 +11,7 @@ ) ;; FIXME: empty -(defmacro defface (name colors docstring group) +(defmacro defface (name colors docstring &key group) (declare (ignore name colors docstring group)) ) diff --git a/src/data-types.lisp b/src/data-types.lisp index 13a7c42..7407b51 100644 --- a/src/data-types.lisp +++ b/src/data-types.lisp @@ -235,6 +235,16 @@ scrolling up (towards the beginning of the buffer).")) (height :type fixnum :initarg :height :accessor frame-height) (minibuffer-window :type window :initarg :minibuffer-window :accessor frame-minibuffer-window) (minibuffers-active :type fixnum :initform 0 :initarg minibuffers-active :accessor frame-minibuffers-active) + ;; echo-area-current is the buffer that holds the current (desired) echo area message, + ;; or nil if none is desired right now. + + ;; echo-area-prev is the buffer that holds the previously displayed echo area message, + ;; or nil to indicate no message. This is normally what's on the screen now. + + ;; These two can point to the same buffer. That happens when the last + ;; message output by the user (or made by echoing) has been displayed. + (echo-area-current :initarg echo-area-current :accessor frame-echo-area-current) + (echo-area-prev :initarg echo-area-current :accessor frame-echo-area-prev) (selected-window :type window :initarg :selected-window :accessor frame-selected-window)) (:documentation "A Lice frame is super cool.")) diff --git a/src/dired.lisp b/src/dired.lisp index 8d32268..e563cac 100644 --- a/src/dired.lisp +++ b/src/dired.lisp @@ -10,19 +10,19 @@ It ignores directory names if they match any string in this list which ends in a slash.") (defun directory-files () - (error "unimplemented")) + (error "unimplemented directory-files")) (defun directory-files-and-attributes () - (error "unimplemented")) + (error "unimplemented directory-files-and-attributes")) (defun file-name-completion () - (error "unimplemented")) + (error "unimplemented file-name-completion")) (defun file-name-all-completions () - (error "unimplemented")) + (error "unimplemented file-name-all-completions")) (defun file-attributes () - (error "unimplemented")) + (error "unimplemented file-attributes")) (defun file-attributes-lessp () - (error "unimplemented")) + (error "unimplemented file-attributes-lessp")) diff --git a/src/echo-area.lisp b/src/echo-area.lisp new file mode 100644 index 0000000..554217b --- /dev/null +++ b/src/echo-area.lisp @@ -0,0 +1,18 @@ +;;; echo area related function. this stuff is in xdisp.c in emacs + +(in-package "LICE") + +(defun ensure-echo-area-buffers () + "Make sure echo area buffers in `echo_buffers' are live. + If they aren't, make new ones." + (unless (and (bufferp (frame-echo-area-current (selected-frame))) + (buffer-live-p (frame-echo-area-current (selected-frame)))) + (let ((buf (get-buffer-create " *Echo Area 0*"))) + (setf (frame-echo-area-current (selected-frame)) buf + (buffer-local 'truncate-lines buf) nil))) + ;; bleh, duplicate code + (unless (and (bufferp (frame-echo-area-pren (selected-frame))) + (buffer-live-p (frame-echo-area-prev (selected-frame)))) + (let ((buf (get-buffer-create " *Echo Area 1*"))) + (setf (frame-echo-area-prev (selected-frame)) buf + (buffer-local 'truncate-lines buf) nil)))) diff --git a/src/editfns.lisp b/src/editfns.lisp index 6969019..2a1839b 100644 --- a/src/editfns.lisp +++ b/src/editfns.lisp @@ -496,106 +496,135 @@ usage: (char-to-string CHAR)" (string char)) (defun buffer-string () - (error "Unimplemented")) + (error "Unimplemented buffer-string")) (defun field-string-no-properties () - (error "Unimplemented")) + (error "Unimplemented field-string-no-properties")) (defun delete-field () - (error "Unimplemented")) + (error "Unimplemented delete-field")) (defmacro save-current-buffer () - (error "Unimplemented")) + (error "Unimplemented save-current-buffer")) (defun bufsize () - (error "Unimplemented")) + (error "Unimplemented bufsize")) (defun point-min-marker () - (error "Unimplemented")) + (error "Unimplemented point-min-marker")) (defun point-max-marker () - (error "Unimplemented")) + (error "Unimplemented point-max-marker")) (defun gap-position () - (error "Unimplemented")) + (error "Unimplemented gap-position")) (defun gap-size () - (error "Unimplemented")) + (error "Unimplemented gap-size")) (defun position-bytes () - (error "Unimplemented")) + (error "Unimplemented position-bytes")) (defun byte-to-position () - (error "Unimplemented")) + (error "Unimplemented byte-to-position")) (defun previous-char () - (error "Unimplemented")) + (error "Unimplemented previous-char")) (defun insert-before-markers () - (error "Unimplemented")) + (error "Unimplemented insert-before-markers")) (defun insert-and-inherit () - (error "Unimplemented")) + (error "Unimplemented insert-and-inherit")) (defun insert-and-inherit-before-markers () - (error "Unimplemented")) + (error "Unimplemented insert-and-inherit-before-markers")) (defun user-login-name () - (error "Unimplemented")) + (error "Unimplemented user-login-name")) (defun user-real-login-name () - (error "Unimplemented")) + (error "Unimplemented user-real-login-name")) (defun user-uid () - (error "Unimplemented")) + (error "Unimplemented user-uid")) (defun user-real-uid () - (error "Unimplemented")) + (error "Unimplemented user-real-uid")) (defun user-full-name () - (error "Unimplemented")) + (error "Unimplemented user-full-name")) (defun emacs-pid () - (error "Unimplemented")) + (error "Unimplemented emacs-pid")) (defun current-time () - (error "Unimplemented")) + (error "Unimplemented" current-time)) (defun format-time-string () - (error "Unimplemented")) + (error "Unimplemented format-time-string")) (defun float-time () - (error "Unimplemented")) + (error "Unimplemented float-time")) (defun decode-time () - (error "Unimplemented")) + (error "Unimplemented decode-time")) (defun encode-time () - (error "Unimplemented")) + (error "Unimplemented encode-time")) (defun current-time-string () - (error "Unimplemented")) + (error "Unimplemented current-time-string")) (defun current-time-zone () - (error "Unimplemented")) + (error "Unimplemented current-time-zone")) (defun set-time-zone-rule () - (error "Unimplemented")) + (error "Unimplemented set-time-zone-rule")) (defun system-name () - (error "Unimplemented")) + (error "Unimplemented system-name")) + +(defun message (string &rest arguments) + "Display a message at the bottom of the screen. +The message also goes into the `*Messages*' buffer. +\(In keyboard macros, that's all it does.) +Return the message. + +The first argument is a format control string, and the rest are data +to be formatted under control of the string. See `format' for details. + +Note: Use (message \"~s\" VALUE) to print the value of expressions and +variables to avoid accidentally interpreting `~' as format specifiers. + +If the first argument is nil or the empty string, the function clears +any existing message; this lets the minibuffer contents show. See +also `current-message'." + (check-type string string) + ;; FIXME: properly implement the echo area + (when (zerop (frame-minibuffers-active (selected-frame))) + (let ((minibuffer (window-buffer (frame-minibuffer-window (selected-frame)))) + (msg (apply #'format nil string arguments))) + (erase-buffer minibuffer) + (buffer-insert minibuffer msg) + (with-current-buffer (get-buffer-create "*messages*") + (goto-char (point-max)) + (insert msg #\Newline))))) (defun message-box () - (error "Unimplemented")) + (error "Unimplemented message-box")) (defun message-or-box () - (error "Unimplemented")) + (error "Unimplemented message-or-box")) (defun current-message () - (error "Unimplemented")) + "Return the string currently displayed in the echo area, or nil if none." + (let ((buf (frame-echo-area-current (selected-frame)))) + (when buf + (make-buffer-string (begv buf) (zv buf) t buf)))) (defun compare-buffer-substrings () - (error "Unimplemented")) + (error "Unimplemented compare-buffer-substrings")) (defun subst-char-in-region (start end fromchar tochar &optional noundo) "From START to END, replace FROMCHAR with TOCHAR each time it occurs. @@ -628,16 +657,16 @@ Both characters must have the same length of multi-byte form." nil)) (defun translate-region-internal () - (error "Unimplemented")) + (error "Unimplemented translate-region-internal")) (defun widen () - (error "Unimplemented")) + (error "Unimplemented widen")) (defun narrow-to-region () - (error "Unimplemented")) + (error "Unimplemented narrow-to-region")) (defun save-restriction () - (error "Unimplemented")) + (error "Unimplemented save-restriction")) (defun transpose-regions (startr1 endr1 startr2 endr2 &optional leave_markers) "Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2. diff --git a/src/elisp.lisp b/src/elisp.lisp index 4314a71..c6dc398 100644 --- a/src/elisp.lisp +++ b/src/elisp.lisp @@ -15,7 +15,7 @@ (cl:defun parse-interactive (thing) - (error "unimplemented")) + (error "unimplemented parse-interactive")) (defmacro defun (name lambda-list &body body) "Parse an elisp style defun and convert it to a cl defun or lice defcommand." diff --git a/src/emacs-lisp/easy-mmode.lisp b/src/emacs-lisp/easy-mmode.lisp index 4891217..42f1402 100644 --- a/src/emacs-lisp/easy-mmode.lisp +++ b/src/emacs-lisp/easy-mmode.lisp @@ -84,16 +84,17 @@ replacing its case-insensitive matches with the literal string in LIGHTER." (replace-regexp-in-string (regexp-quote lighter) lighter name t t)))) ;;;###autoload -(defalias 'easy-mmode-define-minor-mode 'define-minor-mode) +;; FIXME: when aliases really work maybe uncomment this +;;(defalias 'easy-mmode-define-minor-mode 'define-minor-mode) ;;;###autoload (defmacro define-minor-mode ((mode doc ;;&optional init-value lighter keymap &key init-value lighter ((:global globalp)) extra-args set - initialize group type (require t) keymap) + initialize group type (require t) keymap ;; FIXME: in the original any keys not ;; above were added to extra-keywords, ;; but i'm too lazy to do it that way ;; atm. -sabetts - extra-keywords + extra-keywords) &body body) "Define a new minor mode MODE. This function defines the associated control variable MODE, keymap MODE-map, @@ -253,7 +254,7 @@ With zero or negative ARG turn mode off. ;;;###autoload (defalias 'easy-mmode-define-global-mode 'define-global-minor-mode) ;;;###autoload -(defmacro define-global-minor-mode (global-mode mode turn-on &rest keys) +(defmacro define-global-minor-mode (global-mode mode turn-on &key group global extra-keywords) "Make GLOBAL-MODE out of the buffer-local minor MODE. TURN-ON is a function that will be called with no args in every buffer and that should try to turn MODE on if applicable for that buffer. @@ -275,42 +276,32 @@ call another major mode in their body." (let* ((global-mode-name (symbol-name global-mode)) (pretty-name (easy-mmode-pretty-mode-name mode)) (pretty-global-name (easy-mmode-pretty-mode-name global-mode)) - (group nil) - (extra-keywords nil) (MODE-buffers (intern (concat global-mode-name "-buffers"))) (MODE-enable-in-buffers (intern (concat global-mode-name "-enable-in-buffers"))) (MODE-check-buffers (intern (concat global-mode-name "-check-buffers"))) (MODE-cmhh (intern (concat global-mode-name "-cmhh"))) - (MODE-major-mode (intern (concat (symbol-name mode) "-major-mode"))) - keyw) - - ;; Check keys. - (while (keywordp (setq keyw (car keys))) - (setq keys (cdr keys)) - (case keyw - (:group (setq group (nconc group (list :group (pop keys))))) - (:global (setq keys (cdr keys))) - (t (push keyw extra-keywords) (push (pop keys) extra-keywords)))) - - (unless group - ;; We might as well provide a best-guess default group. - (setq group - `(:group ',(intern (replace-regexp-in-string - "-mode\\'" "" (symbol-name mode)))))) + (MODE-major-mode (intern (concat (symbol-name mode) "-major-mode")))) + + ;; FIXME: :group can occur multiple times in the emacs version but not in this one. + + ;; We might as well provide a best-guess default group. + (setq group + `(:group ,(or group '(intern (replace-regexp-in-string + "-mode\\'" "" (symbol-name mode)))))) `(progn (defvar ,MODE-major-mode nil) (make-variable-buffer-local ',MODE-major-mode) ;; The actual global minor-mode (define-minor-mode ,global-mode - ,(format "Toggle %s in every buffer. -With prefix ARG, turn %s on if and only if ARG is positive. -%s is actually not turned on in every buffer but only in those -in which `%s' turns it on." + ,(format nil "Toggle ~a in every buffer. +With prefix ARG, turn ~a on if and only if ARG is positive. +~a is actually not turned on in every buffer but only in those +in which `~s' turns it on." pretty-name pretty-global-name pretty-name turn-on) - :global t ,@group ,@(nreverse extra-keywords) + (:global t ,@group ,@(nreverse extra-keywords)) ;; Setup hook to handle future mode changes and new buffers. (el:if ,global-mode @@ -328,9 +319,10 @@ in which `%s' turns it on." (with-current-buffer buf (if ,global-mode (,turn-on) (when ,mode (,mode -1)))))) - ;; Autoloading define-global-minor-mode autoloads everything - ;; up-to-here. - :autoload-end +;; FIXME: when we figure out autoload stuff maybe uncomment this -sabetts +;; ;; Autoloading define-global-minor-mode autoloads everything +;; ;; up-to-here. +;; :autoload-end ;; List of buffers left to process. (defvar ,MODE-buffers nil) diff --git a/src/lisp/lisp-mode.lisp b/src/emacs-lisp/lisp-mode.lisp similarity index 100% rename from src/lisp/lisp-mode.lisp rename to src/emacs-lisp/lisp-mode.lisp diff --git a/src/emacs.lisp b/src/emacs.lisp index e2f9f46..6201855 100644 --- a/src/emacs.lisp +++ b/src/emacs.lisp @@ -14,3 +14,23 @@ Special values: `:axp-vms' compiled for a (Open)VMS system. Anything else indicates some sort of Unix system. */); Vsystem_type = intern (SYSTEM_TYPE") + +(defvar kill-emacs-hook nil + "Hook to be run when kill-emacs is called. +Since `kill-emacs' may be invoked when the terminal is disconnected (or +in other similar situations), functions placed on this hook should not +expect to be able to interact with the user. To ask for confirmation, +see `kill-emacs-query-functions' instead. + +The hook is not run in batch mode, i.e., if `noninteractive' is non-nil.") + +(defun kill-emacs (&optional arg) + "Exit the Emacs job and kill it. +If ARG is an integer, return ARG as the exit program code. +If ARG is a string, stuff it as keyboard input. + +The value of `kill-emacs-hook', if not void, +is a list of functions (of no args), +all of which are called before Emacs is actually killed." + (run-hooks 'kill-emacs-hook) + (throw 'lice-quit arg)) diff --git a/src/files.lisp b/src/files.lisp index 07d6240..277d119 100644 --- a/src/files.lisp +++ b/src/files.lisp @@ -174,4 +174,35 @@ the last real save, but optional arg FORCE non-nil means delete anyway." (file-error () nil)) (set-buffer-auto-saved)))) +(defcommand save-buffers-kill-emacs () + ;; TODO: save-some-buffers + (kill-emacs)) + +;;; Key bindings + +(define-key *ctl-x-map* "C-f" 'find-file) +(define-key *ctl-x-map* "C-r" 'find-file-read-only) +(define-key *ctl-x-map* "C-v" 'find-alternate-file) +(define-key *ctl-x-map* "C-s" 'save-buffer) +(define-key *ctl-x-map* "s" 'save-some-buffers) +(define-key *ctl-x-map* "C-w" 'write-file) +(define-key *ctl-x-map* "i" 'insert-file) +(define-key *esc-map* "~" 'not-modified) +(define-key *ctl-x-map* "C-d" 'list-directory) +(define-key *ctl-x-map* "C-c" 'save-buffers-kill-emacs) +(define-key *ctl-x-map* "C-q" 'toggle-read-only) + +(define-key *ctl-x-4-map* "f" 'find-file-other-window) +(define-key *ctl-x-4-map* "r" 'find-file-read-only-other-window) +(define-key *ctl-x-4-map* "C-f" 'find-file-other-window) +(define-key *ctl-x-4-map* "b" 'switch-to-buffer-other-window) +(define-key *ctl-x-4-map* "C-o" 'display-buffer) + +(define-key *ctl-x-5-map* "b" 'switch-to-buffer-other-frame) +(define-key *ctl-x-5-map* "f" 'find-file-other-frame) +(define-key *ctl-x-5-map* "C-f" 'find-file-other-frame) +(define-key *ctl-x-5-map* "r" 'find-file-read-only-other-frame) +(define-key *ctl-x-5-map* "C-o" 'display-buffer-other-frame) + + (provide :lice-0.1/files) diff --git a/src/fns.lisp b/src/fns.lisp index dd64c69..ea36572 100644 --- a/src/fns.lisp +++ b/src/fns.lisp @@ -39,3 +39,19 @@ This function allows vectors as well as strings." Comparison done with `eq'. The value is actually the tail of LIST whose car is ELT." (member elt list :test 'eq)) + +(depricate put (setf get)) +(defun put (symbol propname value) + "Store SYMBOL's PROPNAME property with value VALUE. +It can be retrieved with `(get SYMBOL PROPNAME)'." + (setf (get symbol propname) value)) + +(defun featurep (feature &optional subfeature) + "Returns t if FEATURE is present in this Emacs. + +Use this to conditionalize execution of lisp code based on the +presence or absence of Emacs or environment extensions. +Use `provide' to declare that a feature is available. This function +looks at the value of the variable `features'. The optional argument +SUBFEATURE can be used to check a specific subfeature of FEATURE." + (and (find feature *features*) t)) diff --git a/src/frame.lisp b/src/frame.lisp index 5f6dba6..0d922f1 100644 --- a/src/frame.lisp +++ b/src/frame.lisp @@ -50,13 +50,13 @@ See also `frame-live-p'." (typep object 'frame)) (defun frame-live-p () - (error "unimplemented")) + (error "unimplemented frame-live-p")) (defun make-terminal-frame () - (error "unimplemented")) + (error "unimplemented make-terminal-frame")) (defun handle-switch-frame () - (error "unimplemented")) + (error "unimplemented handle-switch-frame")) (defun select-frame (frame) "Select the frame FRAME. @@ -70,13 +70,13 @@ focus. On a text-only terminal, the next redisplay will display FRAME. This function returns FRAME, or nil if FRAME has been deleted." (declare (ignore frame)) - (error "unimplemented")) + (error "unimplemented select-frame")) (defun frame-root-window () - (error "unimplemented")) + (error "unimplemented frame-root-window")) (defun frame-first-window () - (error "unimplemented")) + (error "unimplemented frame-first-window")) (depricate set-frame-selected-window (setf frame-selected-window)) (defun set-frame-selected-window (frame window) @@ -91,85 +91,85 @@ If frame is the selected frame, this makes window the selected window." (copy-list *frame-list*)) (defun next-frame () - (error "unimplemented")) + (error "unimplemented next-frame")) (defun previous-frame () - (error "unimplemented")) + (error "unimplemented previous-frame")) (defun delete-frame () - (error "unimplemented")) + (error "unimplemented delete-frame")) (defun mouse-position () - (error "unimplemented")) + (error "unimplemented mouse-position")) (defun mouse-pixel-position () - (error "unimplemented")) + (error "unimplemented mouse-pixel-position")) (defun set-mouse-position () - (error "unimplemented")) + (error "unimplemented set-mouse-position")) (defun set-mouse-pixel-position () - (error "unimplemented")) + (error "unimplemented set-mouse-pixel-position")) (defun make-frame-visible () - (error "unimplemented")) + (error "unimplemented make-frame-visible")) (defun make-frame-invisible () - (error "unimplemented")) + (error "unimplemented make-frame-invisible")) (defun iconify-frame () - (error "unimplemented")) + (error "unimplemented iconify-frame")) (defun frame-visible-p () - (error "unimplemented")) + (error "unimplemented frame-visible-p")) (defun visible-frame-list () - (error "unimplemented")) + (error "unimplemented visible-frame-list")) (defun raise-frame () - (error "unimplemented")) + (error "unimplemented raise-frame")) (defun lower-frame () - (error "unimplemented")) + (error "unimplemented lower-frame")) (defun redirect-frame-focus () - (error "unimplemented")) + (error "unimplemented redirect-frame-focus")) (defun frame-focus () - (error "unimplemented")) + (error "unimplemented frame-focus")) (defun frame-parameters () - (error "unimplemented")) + (error "unimplemented frame-parameters")) (defun frame-parameter () - (error "unimplemented")) + (error "unimplemented frame-parameter")) (defun modify-frame-parameters () - (error "unimplemented")) + (error "unimplemented modify-frame-parameters")) (defun frame-char-height () - (error "unimplemented")) + (error "unimplemented frame-char-height")) (defun frame-char-width () - (error "unimplemented")) + (error "unimplemented frame-char-width")) (defun frame-pixel-height () - (error "unimplemented")) + (error "unimplemented frame-pixel-height")) (defun frame-pixel-width () - (error "unimplemented")) + (error "unimplemented frame-pixel-width")) (defun set-frame-height () - (error "unimplemented")) + (error "unimplemented set-frame-height")) (defun set-frame-width () - (error "unimplemented")) + (error "unimplemented set-frame-width")) (defun set-frame-size () - (error "unimplemented")) + (error "unimplemented set-frame-size")) (defun set-frame-position () - (error "unimplemented")) + (error "unimplemented set-frame-position")) ;; (defun x-get-resource () diff --git a/src/global.lisp b/src/global.lisp index d0b94f2..0c43653 100644 --- a/src/global.lisp +++ b/src/global.lisp @@ -269,6 +269,6 @@ Does not copy symbols. Copies strings without text properties." (defun garbage-collect () "Reclaim storage for Lisp objects no longer needed." - (warn "unimplemented")) + (warn "unimplemented garbage-collect")) (provide :lice-0.1/global) diff --git a/src/keyboard.lisp b/src/keyboard.lisp index 3ea2e02..8a7d90f 100644 --- a/src/keyboard.lisp +++ b/src/keyboard.lisp @@ -2,6 +2,12 @@ (in-package "LICE") +(defvar deactivate-mark nil + "If an editing command sets this to t, deactivate the mark afterward. +The command loop sets this to nil before each command, +and tests the value when the command returns. +Buffer modification stores t in this variable.") + (defvar help-event-list nil "List of input events to recognize as meaning Help. These work just like the value of `help-char' (see that).") @@ -20,13 +26,6 @@ when the command finishes. The command can change this value if it wants to change what *last-command* will be set to. Used in the `yank' and `yank-pop' commands.") -(defvar *current-prefix-arg* nil - "The value of the prefix argument for this editing command. -It may be a number, or the symbol `-' for just a minus sign as arg, -or a list whose car is a number for just one or more C-u's -or nil if no argument has been specified. -This is what `(interactive \"P\")' returns.") - ;; (defun collect-command-args (cmd) ;; "Return a list of values (some collected from the user) to pass to the CMD function." ;; (mapcar (lambda (arg) @@ -41,6 +40,7 @@ This is what `(interactive \"P\")' returns.") The value is a list of KEYs." *this-command-keys*) +;; FIXME some of this should go in call-interactively (defun dispatch-command (name) (let* ((cmd (lookup-command name)) ;; (args (collect-command-args cmd)) @@ -66,7 +66,7 @@ The value is a list of KEYs." (if *debug-on-error* (signal c) (invoke-restart 'just-print-error c))))) - (funcall (command-fn cmd))) + (call-interactively cmd)) (abort-command () :report "Abort the command." (message "Quit")) @@ -78,9 +78,9 @@ The value is a list of KEYs." ;; handle undo (undo-boundary)) ;; blink - (message "Symbol's command is void: ~a" name) - ;; reset command keys, since the command is over. - *this-command-keys* nil))) + (message "Symbol's command is void: ~a" name)) + ;; reset command keys, since the command is over. + *this-command-keys* nil)) ;;; events @@ -176,14 +176,26 @@ events that invoked the current command." internal-time-units-per-second) time))))) - -(defun top-level-next-event () - ;; Bind this locally so its value is restored after the - ;; command is dispatched. Otherwise, calls to set-buffer - ;; would stick. - (setf *current-buffer* (window-buffer (frame-selected-window (selected-frame)))) - (catch :unbound-key - (next-event))) +(defun command-loop () + (labels ((ensure-current-buffer () + ;; Make sure the current window's buffer is selected. + (unless (eq *current-buffer* (window-buffer (selected-window))) + (setf *current-buffer* (window-buffer (selected-window)))))) + (setf *prefix-arg* nil + *last-prefix-arg* nil) + (loop + (ensure-current-buffer) + (setf deactivate-mark nil) + + (frame-render (selected-frame)) + + ;; execute command + (catch :unbound-key + (next-event)) + ;; A filter may have run while we were reading the input. + (ensure-current-buffer) + +)) ;;; Key bindings diff --git a/src/keymap.lisp b/src/keymap.lisp index 67005e1..62ca974 100644 --- a/src/keymap.lisp +++ b/src/keymap.lisp @@ -154,19 +154,19 @@ keymap is a keymap.")) (defmethod define-key (keymap (key vector) def &optional (theme :lice)) "for some weirdness in bindings.lisp" - (warn "unimplemented")) + (warn "unimplemented define-key")) (defmethod define-key (keymap (key click) def &optional (theme :lice)) "Mouse click events" - (warn "unimplemented")) + (warn "unimplemented define-key")) (defmethod define-key (keymap (key string) (def string) &optional (theme :lice)) "alias a key to another key." - (warn "unimplemented")) + (warn "unimplemented define-key")) (defmethod define-key (keymap (key symbol) def &optional (theme :lice)) "Special events are represented as symbols." - (warn "unimplemented")) + (warn "unimplemented define-key")) (defmethod define-key (keymap (key string) def &optional (theme :lice)) (define-key keymap (parse-key-seq key) def theme)) @@ -222,7 +222,7 @@ Return parent. parent should be nil or another keymap." (defun make-keymap (&optional string) (declare (ignore string)) - (error "unimplemented")) + (error "unimplemented make-keymap")) (defun map-keymap (function keymap &optional (theme :lice)) "Call FUNCTION once for each event binding in KEYMAP. @@ -304,26 +304,26 @@ corresponding command.") (defun copy-keymap (keymap) (declare (ignore keymap)) - (error "unimplemented")) + (error "unimplemented copy-keymap")) (defun command-remapping () - (error "unimplemented")) + (error "unimplemented command-remapping")) (defun key-binding (key &optional accept-default no-remap) (declare (ignore key accept-default no-remap)) - (error "unimplemented")) + (error "unimplemented key-binding")) (defun local-key-binding () - (error "unimplemented")) + (error "unimplemented local-key-binding")) (defun global-key-binding () - (error "unimplemented")) + (error "unimplemented global-key-binding")) (defun minor-mode-key-binding () - (error "unimplemented")) + (error "unimplemented minor-mode-key-binding")) (defun define-prefix-command () - (error "unimplemented")) + (error "unimplemented define-prefix-command")) (defun use-global-map (keymap) (check-type keymap keymap) @@ -347,34 +347,34 @@ not be in the future." *current-global-map*) (defun current-minor-mode-maps () - (error "unimplemented")) + (error "unimplemented current-minor-mode-maps")) (defun current-active-maps () - (error "unimplemented")) + (error "unimplemented current-active-maps")) (defun accessible-keymaps () - (error "unimplemented")) + (error "unimplemented" accessible-keymaps)) (defun key-description () - (error "unimplemented")) + (error "unimplemented key-description")) (defun describe-vector () - (error "unimplemented")) + (error "unimplemented describe-vector")) (defun single-key-description () - (error "unimplemented")) + (error "unimplemented single-key-description")) (defun text-char-description () - (error "unimplemented")) + (error "unimplemented text-char-description")) (defun where-is-internal () - (error "unimplemented")) + (error "unimplemented where-is-internal")) (defun describe-buffer-bindings () - (error "unimplemented")) + (error "unimplemented describe-buffer-bindings")) (defun apropos-internal () - (error "unimplemented")) + (error "unimplemented apropos-internal")) ;; This is a struct to make it easier to add new elements to, should ;; we want to. Also, it makes code easier to read, I think. diff --git a/src/lice.asd b/src/lice.asd index b5cf48b..7ea8277 100644 --- a/src/lice.asd +++ b/src/lice.asd @@ -16,6 +16,7 @@ (:file "data") (:file "custom") (:file "commands") + (:file "callint") (:file "dired") (:file "data-types") (:file "charset") @@ -50,18 +51,19 @@ #+clisp (:file "clisp-render") (:file "indent") + (:module emacs-lisp + :serial t + :components ((:file "easy-mmode") + (:file "lisp-mode"))) + (:module lisp :serial t :components ((:file "subr") (:file "simple") - (:file "lisp-mode") (:file "lisp-indent") (:file "paragraphs") - (:file "bindings"))) - - (:module emacs-lisp - :serial t - :components ((:file "easy-mmode"))) + (:file "bindings") + (:file "paren"))) (:module textmodes :serial t diff --git a/src/lisp/paren.lisp b/src/lisp/paren.lisp new file mode 100644 index 0000000..50708c1 --- /dev/null +++ b/src/lisp/paren.lisp @@ -0,0 +1,261 @@ +;;; paren.el --- highlight matching paren + +;; Copyright (C) 1993, 1996, 2001, 2002, 2003, 2004, +;; 2005, 2006 Free Software Foundation, Inc. + +;; Author: rms@gnu.org +;; Maintainer: FSF +;; Keywords: languages, faces + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Put this into your ~/.emacs: + +;; (show-paren-mode t) + +;; It will display highlighting on whatever paren matches the one +;; before or after point. + +;;; Code: + +(in-package "LICE") + +(defgroup paren-showing nil + "Showing (un)matching of parens and expressions." + :prefix "show-paren-" + :group 'paren-matching) + +;; This is the overlay used to highlight the matching paren. +(defvar show-paren-overlay nil) +;; This is the overlay used to highlight the closeparen right before point. +(defvar show-paren-overlay-1 nil) + +(defcustom show-paren-style 'parenthesis + "*Style used when showing a matching paren. +Valid styles are `parenthesis' (meaning show the matching paren), +`expression' (meaning show the entire expression enclosed by the paren) and +`mixed' (meaning show the matching paren if it is visible, and the expression +otherwise)." + :type '(choice (const parenthesis) (const expression) (const mixed)) + :group 'paren-showing) + +(defcustom show-paren-delay + (if (featurep 'lisp-float-type) (/ (float 1) (float 8)) 1) + "*Time in seconds to delay before showing a matching paren." + :type '(number :tag "seconds") + :group 'paren-showing) + +(defcustom show-paren-priority 1000 + "*Priority of paren highlighting overlays." + :type 'integer + :group 'paren-showing + :version "21.1") + +(defcustom show-paren-ring-bell-on-mismatch nil + "*If non-nil, beep if mismatched paren is detected." + :type 'boolean + :group 'paren-showing + :version "20.3") + +(defgroup paren-showing-faces nil + "Group for faces of Show Paren mode." + :group 'paren-showing + :group 'faces + :version "22.1") + +(defface show-paren-match + '((((class color) (background light)) + :background "turquoise") ; looks OK on tty (becomes cyan) + (((class color) (background dark)) + :background "steelblue3") ; looks OK on tty (becomes blue) + (((background dark)) + :background "grey50") + (t + :background "gray")) + "Show Paren mode face used for a matching paren." + :group 'paren-showing-faces) +;; backward-compatibility alias +(put 'show-paren-match-face 'face-alias 'show-paren-match) + +(defface show-paren-mismatch + '((((class color)) (:foreground "white" :background "purple")) + (t (:inverse-video t))) + "Show Paren mode face used for a mismatching paren." + :group 'paren-showing-faces) +;; backward-compatibility alias +(put 'show-paren-mismatch-face 'face-alias 'show-paren-mismatch) + +(defvar show-paren-highlight-openparen t + "*Non-nil turns on openparen highlighting when matching forward.") + +(defvar show-paren-idle-timer nil) + +;;;###autoload +(define-minor-mode (show-paren-mode + "Toggle Show Paren mode. +With prefix ARG, turn Show Paren mode on if and only if ARG is positive. +Returns the new status of Show Paren mode (non-nil means on). + +When Show Paren mode is enabled, any matching parenthesis is highlighted +in `show-paren-style' after `show-paren-delay' seconds of Emacs idle time." + :global t :group 'paren-showing) + ;; Enable or disable the mechanism. + ;; First get rid of the old idle timer. + (if show-paren-idle-timer + (cancel-timer show-paren-idle-timer)) + (setq show-paren-idle-timer nil) + ;; If show-paren-mode is enabled in some buffer now, + ;; set up a new timer. + (when (memq t (mapcar (lambda (buffer) + (with-current-buffer buffer + show-paren-mode)) + (buffer-list))) + (setq show-paren-idle-timer (run-with-idle-timer + show-paren-delay t + 'show-paren-function))) + (unless show-paren-mode + (and show-paren-overlay + (eq (overlay-buffer show-paren-overlay) (current-buffer)) + (delete-overlay show-paren-overlay)) + (and show-paren-overlay-1 + (eq (overlay-buffer show-paren-overlay-1) (current-buffer)) + (delete-overlay show-paren-overlay-1)))) + +;; Find the place to show, if there is one, +;; and show it until input arrives. +(defun show-paren-function () + (el:if show-paren-mode + (let ((oldpos (point)) + (dir (cond ((eq (syntax-class (syntax-after (1- (point)))) 5) -1) + ((eq (syntax-class (syntax-after (point))) 4) 1))) + pos mismatch face) + ;; + ;; Find the other end of the sexp. + (when dir + (save-excursion + (save-restriction + ;; Determine the range within which to look for a match. + (when blink-matching-paren-distance + (narrow-to-region + (max (point-min) (- (point) blink-matching-paren-distance)) + (min (point-max) (+ (point) blink-matching-paren-distance)))) + ;; Scan across one sexp within that range. + ;; Errors or nil mean there is a mismatch. + (condition-case () + (setq pos (scan-sexps (point) dir)) + (error (setq pos t mismatch t))) + ;; Move back the other way and verify we get back to the + ;; starting point. If not, these two parens don't really match. + ;; Maybe the one at point is escaped and doesn't really count. + (when (integerp pos) + (unless (condition-case () + (eq (point) (scan-sexps pos (- dir))) + (error nil)) + (setq pos nil))) + ;; If found a "matching" paren, see if it is the right + ;; kind of paren to match the one we started at. + (when (integerp pos) + (let ((beg (min pos oldpos)) (end (max pos oldpos))) + (unless (eq (syntax-class (syntax-after beg)) 8) + (setq mismatch + (not (or (eq (char-before end) + ;; This can give nil. + (cdr (syntax-after beg))) + (eq (char-after beg) + ;; This can give nil. + (cdr (syntax-after (1- end)))) + ;; The cdr might hold a new paren-class + ;; info rather than a matching-char info, + ;; in which case the two CDRs should match. + (eq (cdr (syntax-after (1- end))) + (cdr (syntax-after beg)))))))))))) + ;; + ;; Highlight the other end of the sexp, or unhighlight if none. + (el:if (not pos) + (progn + ;; If not at a paren that has a match, + ;; turn off any previous paren highlighting. + (and show-paren-overlay (overlay-buffer show-paren-overlay) + (delete-overlay show-paren-overlay)) + (and show-paren-overlay-1 (overlay-buffer show-paren-overlay-1) + (delete-overlay show-paren-overlay-1))) + ;; + ;; Use the correct face. + (el:if mismatch + (progn + (el:if show-paren-ring-bell-on-mismatch + (beep)) + (setq face 'show-paren-mismatch)) + (setq face 'show-paren-match)) + ;; + ;; If matching backwards, highlight the closeparen + ;; before point as well as its matching open. + ;; If matching forward, and the openparen is unbalanced, + ;; highlight the paren at point to indicate misbalance. + ;; Otherwise, turn off any such highlighting. + (el:if (and (not show-paren-highlight-openparen) (= dir 1) (integerp pos)) + (when (and show-paren-overlay-1 + (overlay-buffer show-paren-overlay-1)) + (delete-overlay show-paren-overlay-1)) + (let ((from (el:if (= dir 1) + (point) + (forward-point -1))) + (to (el:if (= dir 1) + (forward-point 1) + (point)))) + (el:if show-paren-overlay-1 + (move-overlay show-paren-overlay-1 from to (current-buffer)) + (setq show-paren-overlay-1 (make-overlay from to))) + ;; Always set the overlay face, since it varies. + (overlay-put show-paren-overlay-1 'priority show-paren-priority) + (overlay-put show-paren-overlay-1 'face face))) + ;; + ;; Turn on highlighting for the matching paren, if found. + ;; If it's an unmatched paren, turn off any such highlighting. + (unless (integerp pos) + (delete-overlay show-paren-overlay)) + (let ((to (el:if (or (eq show-paren-style 'expression) + (and (eq show-paren-style 'mixed) + (not (pos-visible-in-window-p pos)))) + (point) + pos)) + (from (el:if (or (eq show-paren-style 'expression) + (and (eq show-paren-style 'mixed) + (not (pos-visible-in-window-p pos)))) + pos + (save-excursion + (goto-char pos) + (forward-point (- dir)))))) + (el:if show-paren-overlay + (move-overlay show-paren-overlay from to (current-buffer)) + (setq show-paren-overlay (make-overlay from to)))) + ;; + ;; Always set the overlay face, since it varies. + (overlay-put show-paren-overlay 'priority show-paren-priority) + (overlay-put show-paren-overlay 'face face))) + ;; show-paren-mode is nil in this buffer. + (and show-paren-overlay + (delete-overlay show-paren-overlay)) + (and show-paren-overlay-1 + (delete-overlay show-paren-overlay-1)))) + +(provide 'paren) + +;;; paren.el ends here diff --git a/src/lisp/simple.lisp b/src/lisp/simple.lisp index f565ebb..f7cef39 100644 --- a/src/lisp/simple.lisp +++ b/src/lisp/simple.lisp @@ -520,10 +520,6 @@ the window-buffer correspondences." (record-buffer buffer)) (set-window-buffer w buffer))) -(defcommand save-buffers-kill-emacs () - ;; TODO: save-some-buffers - (throw 'lice-quit t)) - (defun eval-echo (string) ;; FIXME: don't just abandon the output (let* ((stream (make-string-output-stream)) @@ -715,22 +711,6 @@ yanking point; just return the Nth kill forward." ;;; universal argument -(defun prefix-numeric-value (prefix) - "Return numeric meaning of raw prefix argument RAW. -A raw prefix argument is what you get from :raw-prefix. -Its numeric meaning is what you would get from :prefix." - ;; TODO - (cond ((null prefix) - 1) - ((eq prefix '-) - -1) - ((and (consp prefix) - (integerp (car prefix))) - (car prefix)) - ((integerp prefix) - prefix) - (t 1))) - (defun prefix-arg () "Return numeric meaning of *prefix-arg*" (prefix-numeric-value *prefix-arg*)) @@ -1801,11 +1781,11 @@ and the function returns nil. Field boundaries are not noticed if (defun line-number-mode (&optional arg) "" - (warn "Unimplemented")) + (warn "Unimplemented line-number-mode")) (defun column-number-mode (&optional arg) "" - (warn "Unimplemented")) + (warn "Unimplemented column-number-mode")) (provide :lice-0.1/simple) diff --git a/src/lisp/subr.lisp b/src/lisp/subr.lisp index cd2b4a1..c0e2423 100644 --- a/src/lisp/subr.lisp +++ b/src/lisp/subr.lisp @@ -233,7 +233,7 @@ With optional non-nil ALL, force redisplay of all mode lines and header lines. This function also forces recomputation of the menu bar menus and the frame title." (declare (ignore all)) - (error "unimplemented") + (error "unimplemented force-mode-line-update") ;; (if all (save-excursion (set-buffer (other-buffer)))) ;; (set-buffer-modified-p (buffer-modified-p)) ) diff --git a/src/minibuffer.lisp b/src/minibuffer.lisp index 718dd6b..d7dd087 100644 --- a/src/minibuffer.lisp +++ b/src/minibuffer.lisp @@ -144,18 +144,6 @@ If the optional argument FRAME is specified, return the minibuffer window used by that frame." (frame-minibuffer-window frame)) -(defun message (string &rest arguments) - "Print a one-line message at the bottom of the screen." - ;; FIXME: properly implement the echo area - (when (zerop (frame-minibuffers-active (selected-frame))) - (let ((minibuffer (window-buffer (frame-minibuffer-window (selected-frame)))) - (msg (apply #'format nil string arguments))) - (erase-buffer minibuffer) - (buffer-insert minibuffer msg) - (with-current-buffer (get-buffer-create "*messages*") - (goto-char (point-max)) - (insert msg #\Newline))))) - (defun clear-minibuffer () "Erase the text in the minibuffer, unless it's active." (when (zerop (frame-minibuffers-active (selected-frame))) diff --git a/src/recursive-edit.lisp b/src/recursive-edit.lisp index 401e2fc..a8e82fb 100644 --- a/src/recursive-edit.lisp +++ b/src/recursive-edit.lisp @@ -13,10 +13,8 @@ ;; restore the last command (*last-command* *last-command*) (ret (catch 'exit - ;;(with-lice-debugger - (loop - (frame-render (selected-frame)) - (top-level-next-event))))) + (with-lice-debugger + (command-loop))))) ;; return the ret val. (dformat +debug-v+ "ret ~a~%" ret) (when ret diff --git a/src/search.lisp b/src/search.lisp index 592f3e6..01736ca 100644 --- a/src/search.lisp +++ b/src/search.lisp @@ -91,7 +91,7 @@ NEWTEXT in place of subexp N. This is useful only after a regular expression search or match, since only regular expressions have distinguished subexpressions." (declare (ignore newtext fixedcase literal string subexp)) - (error "unimplemented")) + (error "unimplemented replace-match")) (defun match-string-no-properties (num &optional string) @@ -357,10 +357,10 @@ matched by the parenthesis constructions in regexp." "Given a string of words separated by word delimiters, compute a regexp that matches those exact words separated by arbitrary punctuation." - (error "unimplemented")) + (error "unimplemented wordify")) (defun word-search-forward (string &key (bound (begv)) (error t) count &aux (buffer (current-buffer))) - (error "unimplemented")) + (error "unimplemented word-search-forward")) (defun scan-buffer (buffer target start end count) "Search for COUNT instances of the character TARGET between START and END. diff --git a/src/subprocesses.lisp b/src/subprocesses.lisp index 1276ca2..e1a209a 100644 --- a/src/subprocesses.lisp +++ b/src/subprocesses.lisp @@ -199,7 +199,7 @@ service is name of the service desired, or an integer specifying a port number to connect to." (declare (ignore name buffer host service)) ;; TODO: implement - (error "unimplemented") + (error "unimplemented open-network-stream") ) (defvar *shell-file-name* (getenv "SHELL") diff --git a/src/textprop.lisp b/src/textprop.lisp index a558d25..c280ba1 100644 --- a/src/textprop.lisp +++ b/src/textprop.lisp @@ -524,7 +524,7 @@ the current buffer), START and END are buffer positions (integers or markers). If OBJECT is a string, START and END are 0-based indices into it. Return t if any property was actually removed, nil otherwise." (declare (ignore start and list-of-properties object)) - (error "unimplemented")) + (error "unimplemented remove-list-of-text-properties")) (provide :lice-0.1/textprop) diff --git a/src/window.lisp b/src/window.lisp index f60d6b8..627cd08 100644 --- a/src/window.lisp +++ b/src/window.lisp @@ -845,7 +845,7 @@ If you use consistent values for MINIBUF and ALL-FRAMES, you can use windows, eventually ending up back at the window you started with. `next-window' traverses the same cycle, in the reverse order." (declare (ignore window minibuf all-frames)) - (error "unimplemented")) + (error "unimplemented previous-window")) (defcommand other-window ((arg &optional all-frames) :prefix)