Changeset 8461 for trunk/j/src/org/armedbear

Timestamp:

02/04/05 04:28:47 (19 years ago)

Author:

piso

Message:

Work in progress.

Location:

trunk/j/src/org/armedbear

Files:

• j/LispAPI.java (modified) (7 diffs)
• lisp/slime.lisp (modified) (5 diffs)

trunk/j/src/org/armedbear/j/LispAPI.java

@@ -2 +2 @@
  * LispAPI.java
  *
- * Copyright (C) 2003-2004 Peter Graves
- * $Id: LispAPI.java,v 1.58 2004-11-28 15:44:25 piso Exp $
+ * Copyright (C) 2003-2005 Peter Graves
+ * $Id: LispAPI.java,v 1.59 2005-02-04 04:27:23 piso Exp $
  *
  * This program is free software; you can redistribute it and/or
@@ -424 +424 @@
     // ### make-mark
     private static final Primitive MAKE_MARK =
-        new Primitive("make-mark", PACKAGE_J, true)
+        new Primitive("make-mark", PACKAGE_J, true, "line offset")
     {
         public LispObject execute(LispObject first, LispObject second)
@@ -437 +437 @@
     // ### mark-line
     private static final Primitive MARK_LINE =
-        new Primitive("mark-line", PACKAGE_J, true)
+        new Primitive("mark-line", PACKAGE_J, true, "mark")
     {
         public LispObject execute(LispObject arg) throws ConditionThrowable
@@ -447 +447 @@
     // ### mark-charpos
     private static final Primitive MARK_CHARPOS =
-        new Primitive("mark-charpos", PACKAGE_J, true)
+        new Primitive("mark-charpos", PACKAGE_J, true, "mark")
     {
         public LispObject execute(LispObject arg) throws ConditionThrowable
@@ -562 +562 @@
     // Move point right N characters (left if N is negative).
     private static final Primitive FORWARD_CHAR =
-        new Primitive("forward-char", PACKAGE_J, true)
-    {
-        public LispObject execute() throws ConditionThrowable
-        {
-            return forwardChar(1);
-        }
-        public LispObject execute(LispObject arg) throws ConditionThrowable
-        {
-            return forwardChar(Fixnum.getValue(arg));
+        new Primitive("forward-char", PACKAGE_J, true, "mark &optional count")
+    {
+        public LispObject execute(LispObject arg) throws ConditionThrowable
+        {
+            Position pos = checkMark(arg);
+            return forwardChar(pos, 1);
+        }
+        public LispObject execute(LispObject first, LispObject second)
+            throws ConditionThrowable
+        {
+            Position pos = checkMark(first);
+            return forwardChar(pos, Fixnum.getValue(second));
         }
     };
 
     // ### backward-char
-    // Move point left N characters (right if N is negative).
+    // Move MARK left COUNT characters (right if COUNT is negative).
     private static final Primitive BACKWARD_CHAR =
-        new Primitive("backward-char", PACKAGE_J, true)
-    {
-        public LispObject execute() throws ConditionThrowable
-        {
-            return forwardChar(-1);
-        }
-        public LispObject execute(LispObject arg) throws ConditionThrowable
-        {
-            return forwardChar(-Fixnum.getValue(arg));
-        }
-    };
-
-    private static final LispObject forwardChar(int n) throws ConditionThrowable
+        new Primitive("backward-char", PACKAGE_J, true, "mark &optional count")
+    {
+        public LispObject execute(LispObject arg) throws ConditionThrowable
+        {
+            Position pos = checkMark(arg);
+            return forwardChar(pos, -1);
+        }
+        public LispObject execute(LispObject first, LispObject second)
+            throws ConditionThrowable
+        {
+            Position pos = checkMark(first);
+            return forwardChar(pos, -Fixnum.getValue(second));
+        }
+    };
+
+    private static final LispObject forwardChar(Position pos, int n)
+        throws ConditionThrowable
     {
         if (n != 0) {
-            final Editor editor = Editor.currentEditor();
-            Position pos = editor.getDot();
             if (pos != null) {
-                editor.addUndo(SimpleEdit.MOVE);
                 if (n > 0) {
                     while (n-- > 0) {
                         if (!pos.next())
-                            return signal(new LispError("reached end of buffer"));
+                            return signal(new LispError("Reached end of buffer."));
                     }
                 } else {
-                    Debug.assertTrue(n < 0);
                     while (n++ < 0) {
                         if (!pos.prev())
-                            return signal(new LispError("reached beginning of buffer"));
+                            return signal(new LispError("Reached beginning of buffer."));
                     }
                 }
-                editor.moveCaretToDotCol();
             }
         }
@@ -674 +676 @@
     };
 
-    // ### backward-up-list
+    // ### backward-up-list mark
     private static final Primitive BACKWARD_UP_LIST =
-        new Primitive("backward-up-list", PACKAGE_J, true)
-    {
-        public LispObject execute() throws ConditionThrowable
-        {
-            LispMode.backwardUpList();
-            return NIL;
-        }
-    };
-
-    // ### looking-at pattern => generalized-boolean
+        new Primitive("backward-up-list", PACKAGE_J, true, "mark")
+    {
+        public LispObject execute(LispObject arg) throws ConditionThrowable
+        {
+            Position pos = checkMark(arg);
+            Position newPos = LispMode.findContainingSexp(pos);
+            if (newPos != null)
+                pos.moveTo(newPos);
+            return arg;
+        }
+    };
+
+    // ### looking-at mark pattern => generalized-boolean
     private static final Primitive LOOKING_AT =
-        new Primitive("looking-at", PACKAGE_J, true)
-    {
-        public LispObject execute(LispObject arg) throws ConditionThrowable
-        {
-            if (arg instanceof AbstractString) {
-                String pattern = arg.getStringValue();
-                Editor editor = Editor.currentEditor();
-                Position dot = editor.getDot();
-                if (dot != null) {
-                    if (dot.getLine().substring(dot.getOffset()).startsWith(pattern))
-                        return T;
-                }
+        new Primitive("looking-at", PACKAGE_J, true, "mark string")
+    {
+        public LispObject execute(LispObject first, LispObject second)
+            throws ConditionThrowable
+        {
+            Position pos = checkMark(first);
+            if (second instanceof AbstractString) {
+                String pattern = second.getStringValue();
+                if (pos.getLine().substring(pos.getOffset()).startsWith(pattern))
+                    return T;
                 return NIL;
             }
-            return signal(new TypeError(arg, Symbol.STRING));
+            return signal(new TypeError(second, Symbol.STRING));
         }
     };
@@ -1020 +1023 @@
                 editor.unmark();
             return arg;
+        }
+    };
+
+    // ### copy-mark mark => copy
+    private static final Primitive COPY_MARK =
+        new Primitive("copy-mark", PACKAGE_J, true, "mark")
+    {
+        public LispObject execute(LispObject arg) throws ConditionThrowable
+        {
+            Position pos = checkMark(arg);
+            return new JavaObject(new Position(pos.getLine(), pos.getOffset()));
+        }
+    };
+
+    // ### mark= mark1 mark2 => generalized-boolean
+    private static final Primitive MARK_EQUAL =
+        new Primitive("mark=", PACKAGE_J, true, "mark1 mark2")
+    {
+        public LispObject execute(LispObject first, LispObject second)
+            throws ConditionThrowable
+        {
+            Position pos1 = checkMark(first);
+            Position pos2 = checkMark(second);
+            if (pos1.getLine() == pos2.getLine())
+                if (pos1.getOffset() == pos2.getOffset())
+                    return T;
+            return NIL;
         }
     };

trunk/j/src/org/armedbear/lisp/slime.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2004-2005 Peter Graves
-;;; $Id: slime.lisp,v 1.27 2005-02-01 03:38:22 piso Exp $
+;;; $Id: slime.lisp,v 1.28 2005-02-04 04:28:47 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -231 +231 @@
   (values))
 
-(defun symbol-name-at-point ()
-  (let ((string (line-chars (current-line)))
-        (point-charpos (mark-charpos (current-point)))
-        (begin 0)
-        end)
-    (when (= point-charpos (length string))
-      (decf point-charpos))
+(defun symbol-name-at-mark (mark)
+  (let* ((string (line-chars (mark-line mark)))
+         (length (length string))
+         (charpos (mark-charpos mark))
+         (begin 0)
+         end)
+    (when (= charpos length)
+      (decf charpos))
     (loop
-      (aver (< point-charpos (length string)))
-      (cond ((not (delimiter-p (schar string point-charpos)))
+      (aver (< charpos length))
+      (cond ((not (delimiter-p (schar string charpos)))
              (return))
-            ((zerop point-charpos)
-             (return-from symbol-name-at-point nil))
+            ((zerop charpos)
+             (return-from symbol-name-at-mark nil))
             (t
-             (decf point-charpos))))
-    (dotimes (i point-charpos)
+             (decf charpos))))
+    (dotimes (i charpos)
       (let ((c (schar string i)))
         (when (delimiter-p c)
           (setf begin (1+ i)))))
-    (do ((i point-charpos (1+ i)))
-        ((= i (length string)) (setf end i))
+    (do ((i charpos (1+ i)))
+        ((= i length) (setf end i))
       (when (delimiter-p (schar string i))
         (setf end i)
@@ -257 +258 @@
     (subseq string begin end)))
 
-(defun enclosing-operator-names ()
+(defun enclosing-operator-names (mark)
   "Return the list of operator names of the forms containing point."
   (let ((result ()))
-    (save-excursion
-      (loop
-        (let ((point1 (current-point))
-              (point2 (progn (backward-up-list) (current-point))))
-          (when (and (equal (mark-line point1) (mark-line point2))
-                     (eql (mark-charpos point1) (mark-charpos point2)))
-            (return)))
-        (unless (looking-at "(")
-          (return))
-        (when (looking-at "(")
-          (forward-char)
-          (let ((name (symbol-name-at-point)))
-            (cond ((string-equal name "defun")
-                   (return))
-                  ((null name)
-                   (return))
-                  (t
-                   (push name result))))
-          (backward-up-list))))
+    (loop
+      (let* ((mark1 (copy-mark mark))
+             (mark2 (progn (backward-up-list mark) (copy-mark mark))))
+        (when (mark= mark1 mark2) ; Can't go back any further.
+          (return)))
+      (unless (looking-at mark "(")
+        (return))
+      (forward-char mark)
+      (let ((name (symbol-name-at-mark mark)))
+        (cond ((string-equal name "defun")
+               (return))
+              ((null name)
+               (return))
+              (t
+               (push name result))))
+      (backward-up-list mark))
     (nreverse result)))
 
 (defun slime-space ()
   (unwind-protect
-   (when (and (slime-connected-p)
-              (not (slime-busy-p)))
-     (let ((names (enclosing-operator-names)))
-       (when names
-         (slime-eval-async
-          `(swank:arglist-for-echo-area (quote ,names))
-          #'(lambda (message)
-             (when (stringp message)
-               (status (string-trim '(#\") message))))))))
-   (insert #\space)))
+      (when (and (slime-connected-p)
+                 (not (slime-busy-p)))
+        (let ((names (enclosing-operator-names (current-point))))
+          (when names
+            (slime-eval-async
+             `(swank:arglist-for-echo-area (quote ,names))
+             #'(lambda (message)
+                (when (stringp message)
+                  (status (string-trim '(#\") message))))))))
+    (insert #\space)))
 
 (defun find-buffer-package ()
@@ -376 +374 @@
       (return-from slime-edit-definition)))
   (unless function-name
-    (setf function-name (string-upcase (symbol-name-at-point))))
+    (setf function-name (string-upcase (symbol-name-at-mark (current-point)))))
   (when function-name
     (setf function-name (string function-name))
@@ -448 +446 @@
 (map-key-for-mode "Ctrl Alt I" "(slime:slime-complete-symbol)" "Lisp")
 (map-key-for-mode "Space" "(slime:slime-space)" "Lisp Shell")
-;; (map-key-for-mode "Space" "(slime:slime-space)" "Lisp")
+(map-key-for-mode "Space" "(slime:slime-space)" "Lisp")
 (map-key-for-mode "Alt ." "(slime:slime-edit-definition)" "Lisp Shell")
 (map-key-for-mode "Alt ." "(slime:slime-edit-definition)" "Lisp")