code.delx.au - gnu-emacs/blob - src/marker.c

   1 /* Markers: examining, setting and killing.
   2    Copyright (C) 1985 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20
  21 #include <config.h>
  22 #include "lisp.h"
  23 #include "buffer.h"
  24
  25 /* Operations on markers. */
  26
  27 DEFUN ("marker-buffer", Fmarker_buffer, Smarker_buffer, 1, 1, 0,
  28   "Return the buffer that MARKER points into, or nil if none.\n\
  29 Returns nil if MARKER points into a dead buffer.")
  30   (marker)
  31      register Lisp_Object marker;
  32 {
  33   register Lisp_Object buf;
  34   CHECK_MARKER (marker, 0);
  35   if (XMARKER (marker)->buffer)
  36     {
  37       XSETBUFFER (buf, XMARKER (marker)->buffer);
  38       /* Return marker's buffer only if it is not dead.  */
  39       if (!NILP (XBUFFER (buf)->name))
  40         return buf;
  41     }
  42   return Qnil;
  43 }
  44
  45 DEFUN ("marker-position", Fmarker_position, Smarker_position, 1, 1, 0,
  46   "Return the position MARKER points at, as a character number.")
  47   (marker)
  48      Lisp_Object marker;
  49 {
  50   register Lisp_Object pos;
  51   register int i;
  52   register struct buffer *buf;
  53
  54   CHECK_MARKER (marker, 0);
  55   if (XMARKER (marker)->buffer)
  56     {
  57       buf = XMARKER (marker)->buffer;
  58       i = XMARKER (marker)->bufpos;
  59
  60       if (i > BUF_GPT (buf) + BUF_GAP_SIZE (buf))
  61         i -= BUF_GAP_SIZE (buf);
  62       else if (i > BUF_GPT (buf))
  63         i = BUF_GPT (buf);
  64
  65       if (i < BUF_BEG (buf) || i > BUF_Z (buf))
  66         abort ();
  67
  68       XSETFASTINT (pos, i);
  69       return pos;
  70     }
  71   return Qnil;
  72 }
  73 \f
  74 DEFUN ("set-marker", Fset_marker, Sset_marker, 2, 3, 0,
  75   "Position MARKER before character number NUMBER in BUFFER.\n\
  76 BUFFER defaults to the current buffer.\n\
  77 If NUMBER is nil, makes marker point nowhere.\n\
  78 Then it no longer slows down editing in any buffer.\n\
  79 Returns MARKER.")
  80   (marker, pos, buffer)
  81      Lisp_Object marker, pos, buffer;
  82 {
  83   register int charno;
  84   register struct buffer *b;
  85   register struct Lisp_Marker *m;
  86
  87   CHECK_MARKER (marker, 0);
  88   /* If position is nil or a marker that points nowhere,
  89      make this marker point nowhere.  */
  90   if (NILP (pos)
  91       || (MARKERP (pos) && !XMARKER (pos)->buffer))
  92     {
  93       unchain_marker (marker);
  94       return marker;
  95     }
  96
  97   CHECK_NUMBER_COERCE_MARKER (pos, 1);
  98   if (NILP (buffer))
  99     b = current_buffer;
 100   else
 101     {
 102       CHECK_BUFFER (buffer, 1);
 103       b = XBUFFER (buffer);
 104       /* If buffer is dead, set marker to point nowhere.  */
 105       if (EQ (b->name, Qnil))
 106         {
 107           unchain_marker (marker);
 108           return marker;
 109         }
 110     }
 111
 112   charno = XINT (pos);
 113   m = XMARKER (marker);
 114
 115   if (charno < BUF_BEG (b))
 116     charno = BUF_BEG (b);
 117   if (charno > BUF_Z (b))
 118     charno = BUF_Z (b);
 119   if (charno > BUF_GPT (b)) charno += BUF_GAP_SIZE (b);
 120   m->bufpos = charno;
 121
 122   if (m->buffer != b)
 123     {
 124       unchain_marker (marker);
 125       m->buffer = b;
 126       m->chain = BUF_MARKERS (b);
 127       BUF_MARKERS (b) = marker;
 128     }
 129
 130   return marker;
 131 }
 132
 133 /* This version of Fset_marker won't let the position
 134    be outside the visible part.  */
 135
 136 Lisp_Object
 137 set_marker_restricted (marker, pos, buffer)
 138      Lisp_Object marker, pos, buffer;
 139 {
 140   register int charno;
 141   register struct buffer *b;
 142   register struct Lisp_Marker *m;
 143
 144   CHECK_MARKER (marker, 0);
 145   /* If position is nil or a marker that points nowhere,
 146      make this marker point nowhere.  */
 147   if (NILP (pos) ||
 148       (MARKERP (pos) && !XMARKER (pos)->buffer))
 149     {
 150       unchain_marker (marker);
 151       return marker;
 152     }
 153
 154   CHECK_NUMBER_COERCE_MARKER (pos, 1);
 155   if (NILP (buffer))
 156     b = current_buffer;
 157   else
 158     {
 159       CHECK_BUFFER (buffer, 1);
 160       b = XBUFFER (buffer);
 161       /* If buffer is dead, set marker to point nowhere.  */
 162       if (EQ (b->name, Qnil))
 163         {
 164           unchain_marker (marker);
 165           return marker;
 166         }
 167     }
 168
 169   charno = XINT (pos);
 170   m = XMARKER (marker);
 171
 172   if (charno < BUF_BEGV (b))
 173     charno = BUF_BEGV (b);
 174   if (charno > BUF_ZV (b))
 175     charno = BUF_ZV (b);
 176   if (charno > BUF_GPT (b))
 177     charno += BUF_GAP_SIZE (b);
 178   m->bufpos = charno;
 179
 180   if (m->buffer != b)
 181     {
 182       unchain_marker (marker);
 183       m->buffer = b;
 184       m->chain = BUF_MARKERS (b);
 185       BUF_MARKERS (b) = marker;
 186     }
 187
 188   return marker;
 189 }
 190
 191 /* This is called during garbage collection,
 192    so we must be careful to ignore and preserve mark bits,
 193    including those in chain fields of markers.  */
 194
 195 unchain_marker (marker)
 196      register Lisp_Object marker;
 197 {
 198   register Lisp_Object tail, prev, next;
 199   register EMACS_INT omark;
 200   register struct buffer *b;
 201
 202   b = XMARKER (marker)->buffer;
 203   if (b == 0)
 204     return;
 205
 206   if (EQ (b->name, Qnil))
 207     abort ();
 208
 209   tail = BUF_MARKERS (b);
 210   prev = Qnil;
 211   while (XSYMBOL (tail) != XSYMBOL (Qnil))
 212     {
 213       next = XMARKER (tail)->chain;
 214       XUNMARK (next);
 215
 216       if (XMARKER (marker) == XMARKER (tail))
 217         {
 218           if (NILP (prev))
 219             {
 220               BUF_MARKERS (b) = next;
 221               /* Deleting first marker from the buffer's chain.  Crash
 222                  if new first marker in chain does not say it belongs
 223                  to the same buffer, or at least that they have the same
 224                  base buffer.  */
 225               if (!NILP (next) && b->text != XMARKER (next)->buffer->text)
 226                 abort ();
 227             }
 228           else
 229             {
 230               omark = XMARKBIT (XMARKER (prev)->chain);
 231               XMARKER (prev)->chain = next;
 232               XSETMARKBIT (XMARKER (prev)->chain, omark);
 233             }
 234           break;
 235         }
 236       else
 237         prev = tail;
 238       tail = next;
 239     }
 240   XMARKER (marker)->buffer = 0;
 241 }
 242
 243 /* Return the buffer position of marker MARKER, as a C integer.  */
 244
 245 int
 246 marker_position (marker)
 247      Lisp_Object marker;
 248 {
 249   register struct Lisp_Marker *m = XMARKER (marker);
 250   register struct buffer *buf = m->buffer;
 251   register int i = m->bufpos;
 252
 253   if (!buf)
 254     error ("Marker does not point anywhere");
 255
 256   if (i > BUF_GPT (buf) + BUF_GAP_SIZE (buf))
 257     i -= BUF_GAP_SIZE (buf);
 258   else if (i > BUF_GPT (buf))
 259     i = BUF_GPT (buf);
 260
 261   if (i < BUF_BEG (buf) || i > BUF_Z (buf))
 262     abort ();
 263
 264   return i;
 265 }
 266 \f
 267 DEFUN ("copy-marker", Fcopy_marker, Scopy_marker, 1, 2, 0,
 268   "Return a new marker pointing at the same place as MARKER.\n\
 269 If argument is a number, makes a new marker pointing\n\
 270 at that position in the current buffer.\n\
 271 The optional argument TYPE specifies the insertion type of the new marker;\n\
 272 see `marker-insertion-type'.")
 273   (marker, type)
 274      register Lisp_Object marker, type;
 275 {
 276   register Lisp_Object new;
 277
 278   if (INTEGERP (marker) || MARKERP (marker))
 279     {
 280       new = Fmake_marker ();
 281       Fset_marker (new, marker,
 282                    (MARKERP (marker) ? Fmarker_buffer (marker) : Qnil));
 283       XMARKER (new)->insertion_type = !NILP (type);
 284       return new;
 285     }
 286   else
 287     marker = wrong_type_argument (Qinteger_or_marker_p, marker);
 288 }
 289
 290 DEFUN ("marker-insertion-type", Fmarker_insertion_type,
 291        Smarker_insertion_type, 1, 1, 0,
 292   "Return insertion type of MARKER: t if it stays after inserted text.\n\
 293 nil means the marker stays before text inserted there.")
 294   (marker)
 295      register Lisp_Object marker;
 296 {
 297   register Lisp_Object buf;
 298   CHECK_MARKER (marker, 0);
 299   return XMARKER (marker)->insertion_type ? Qt : Qnil;
 300 }
 301
 302 DEFUN ("set-marker-insertion-type", Fset_marker_insertion_type,
 303        Sset_marker_insertion_type, 2, 2, 0,
 304   "Set the insertion-type of MARKER to TYPE.\n\
 305 If TYPE is t, it means the marker advances when you insert text at it.\n\
 306 If TYPE is nil, it means the marker stays behind when you insert text at it.")
 307   (marker, type)
 308      Lisp_Object marker, type;
 309 {
 310   CHECK_MARKER (marker, 0);
 311
 312   XMARKER (marker)->insertion_type = ! NILP (type);
 313   return type;
 314 }
 315 \f
 316 syms_of_marker ()
 317 {
 318   defsubr (&Smarker_position);
 319   defsubr (&Smarker_buffer);
 320   defsubr (&Sset_marker);
 321   defsubr (&Scopy_marker);
 322   defsubr (&Smarker_insertion_type);
 323   defsubr (&Sset_marker_insertion_type);
 324 }