[lice @ shit loads of stuff]
authortailor <sabetts@vcn.bc.ca>
Fri, 24 Aug 2007 22:41:19 +0000 (24 22:41 +0000)
committertailor <sabetts@vcn.bc.ca>
Fri, 24 Aug 2007 22:41:19 +0000 (24 22:41 +0000)
31 files changed:
src/Makefile.in
src/callint.lisp [new file with mode: 0644]
src/casefiddle.lisp
src/charset.lisp
src/cmds.lisp
src/commands.lisp
src/custom.lisp
src/data-types.lisp
src/dired.lisp
src/echo-area.lisp [new file with mode: 0644]
src/editfns.lisp
src/elisp.lisp
src/emacs-lisp/easy-mmode.lisp
src/emacs-lisp/lisp-mode.lisp [moved from src/lisp/lisp-mode.lisp with 100% similarity]
src/emacs.lisp
src/files.lisp
src/fns.lisp
src/frame.lisp
src/global.lisp
src/keyboard.lisp
src/keymap.lisp
src/lice.asd
src/lisp/paren.lisp [new file with mode: 0644]
src/lisp/simple.lisp
src/lisp/subr.lisp
src/minibuffer.lisp
src/recursive-edit.lisp
src/search.lisp
src/subprocesses.lisp
src/textprop.lisp
src/window.lisp

index d924b72..0aa10f1 100644 (file)
@@ -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 (file)
index 0000000..d40ce24
--- /dev/null
@@ -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)))
index deedaab..f4e2c12 100644 (file)
@@ -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
 
index 8567701..f68cdc2 100644 (file)
@@ -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"))
index cfea3c6..33b343e 100644 (file)
@@ -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."
index 021a3c2..bd10c3c 100644 (file)
@@ -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
index ede2e85..23aa9c5 100644 (file)
@@ -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))
   )
 
index 13a7c42..7407b51 100644 (file)
@@ -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."))
 
index 8d32268..e563cac 100644 (file)
@@ -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 (file)
index 0000000..554217b
--- /dev/null
@@ -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))))
index 6969019..2a1839b 100644 (file)
@@ -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.
index 4314a71..c6dc398 100644 (file)
@@ -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."
index 4891217..42f1402 100644 (file)
@@ -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)
index e2f9f46..6201855 100644 (file)
@@ -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))
index 07d6240..277d119 100644 (file)
@@ -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)
index dd64c69..ea36572 100644 (file)
@@ -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))
index 5f6dba6..0d922f1 100644 (file)
@@ -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 ()
index d0b94f2..0c43653 100644 (file)
@@ -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)
index 3ea2e02..8a7d90f 100644 (file)
@@ -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
 
index 67005e1..62ca974 100644 (file)
@@ -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.
index b5cf48b..7ea8277 100644 (file)
@@ -16,6 +16,7 @@
                  (:file "data")
                  (:file "custom")
                  (:file "commands")
+                 (:file "callint")
                  (:file "dired")
                  (:file "data-types")
                  (:file "charset")
                  #+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 (file)
index 0000000..50708c1
--- /dev/null
@@ -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
index f565ebb..f7cef39 100644 (file)
@@ -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)
index cd2b4a1..c0e2423 100644 (file)
@@ -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))
   )
index 718dd6b..d7dd087 100644 (file)
@@ -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)))
index 401e2fc..a8e82fb 100644 (file)
          ;; 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
index 592f3e6..01736ca 100644 (file)
@@ -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.
index 1276ca2..e1a209a 100644 (file)
@@ -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")
index a558d25..c280ba1 100644 (file)
@@ -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)
index f60d6b8..627cd08 100644 (file)
@@ -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)