Ejemplo n.º 1
0
static void
single_keymap_panes (Lisp_Object keymap, Lisp_Object pane_name,
		     Lisp_Object prefix, int maxdepth)
{
  struct skp skp;

  skp.pending_maps = Qnil;
  skp.maxdepth = maxdepth;
  skp.notbuttons = 0;

  if (maxdepth <= 0)
    return;

  push_menu_pane (pane_name, prefix);

  if (!have_boxes ())
    {
      /* Remember index for first item in this pane so we can go back
	 and add a prefix when (if) we see the first button.  After
	 that, notbuttons is set to 0, to mark that we have seen a
	 button and all non button items need a prefix.  */
      skp.notbuttons = menu_items_used;
    }

  map_keymap_canonical (keymap, single_menu_item, Qnil, &skp);

  /* Process now any submenus which want to be panes at this level.  */
  while (CONSP (skp.pending_maps))
    {
      Lisp_Object elt, eltcdr, string;
      elt = XCAR (skp.pending_maps);
      eltcdr = XCDR (elt);
      string = XCAR (eltcdr);
      /* We no longer discard the @ from the beginning of the string here.
	 Instead, we do this in *menu_show.  */
      single_keymap_panes (Fcar (elt), string, XCDR (eltcdr), maxdepth - 1);
      skp.pending_maps = XCDR (skp.pending_maps);
    }
}
Ejemplo n.º 2
0
Archivo: undo.c Proyecto: aixoss/emacs
static void
record_point (ptrdiff_t pt)
{
  bool at_boundary;

  /* Don't record position of pt when undo_inhibit_record_point holds.  */
  if (undo_inhibit_record_point)
    return;

  /* Allocate a cons cell to be the undo boundary after this command.  */
  if (NILP (pending_boundary))
    pending_boundary = Fcons (Qnil, Qnil);

  if ((current_buffer != last_undo_buffer)
      /* Don't call Fundo_boundary for the first change.  Otherwise we
	 risk overwriting last_boundary_position in Fundo_boundary with
	 PT of the current buffer and as a consequence not insert an
	 undo boundary because last_boundary_position will equal pt in
	 the test at the end of the present function (Bug#731).  */
      && (MODIFF > SAVE_MODIFF))
    Fundo_boundary ();
  last_undo_buffer = current_buffer;

  at_boundary = ! CONSP (BVAR (current_buffer, undo_list))
                || NILP (XCAR (BVAR (current_buffer, undo_list)));

  if (MODIFF <= SAVE_MODIFF)
    record_first_change ();

  /* If we are just after an undo boundary, and
     point wasn't at start of deleted range, record where it was.  */
  if (at_boundary
      && current_buffer == last_boundary_buffer
      && last_boundary_position != pt)
    bset_undo_list (current_buffer,
		    Fcons (make_number (last_boundary_position),
			   BVAR (current_buffer, undo_list)));
}
Ejemplo n.º 3
0
static Lisp_Object
get_fringe_bitmap_name (int bn)
{
  Lisp_Object bitmaps;
  Lisp_Object num;

  /* Zero means no bitmap -- return nil.  */
  if (bn <= 0)
    return Qnil;

  bitmaps = Vfringe_bitmaps;
  num = make_number (bn);

  while (CONSP (bitmaps))
    {
      Lisp_Object bitmap = XCAR (bitmaps);
      if (EQ (num, Fget (bitmap, Qfringe)))
	return bitmap;
      bitmaps = XCDR (bitmaps);
    }

  return num;
}
Ejemplo n.º 4
0
/** Lookup a variable in a frame */
SCM_EXPORT ScmRef
scm_lookup_frame(ScmObj var, ScmObj frame)
{
    ScmObj formals;
    ScmRef actuals;
    DECLARE_INTERNAL_FUNCTION("scm_lookup_frame");

    SCM_ASSERT(IDENTIFIERP(var));
    SCM_ASSERT(valid_framep(frame));

    for (formals = CAR(frame), actuals = REF_CDR(frame);
         CONSP(formals);
         formals = CDR(formals), actuals = REF_CDR(DEREF(actuals)))
    {
        if (EQ(var, CAR(formals)))
            return REF_CAR(DEREF(actuals));
    }
    /* dotted list */
    if (EQ(var, formals))
        return actuals;

    return SCM_INVALID_REF;
}
Ejemplo n.º 5
0
Lisp_Object
menu_parse_submenu_keywords (Lisp_Object desc, Lisp_Object gui_item)
{
  Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item);

  /* Menu descriptor should be a list */
  CHECK_CONS (desc);

  /* First element may be menu name, although can be omitted.
     Let's think that if stuff begins with anything than a keyword
     or a list (submenu), this is a menu name, expected to be a string */
  if (!KEYWORDP (XCAR (desc)) && !CONSP (XCAR (desc)))
    {
      CHECK_STRING (XCAR (desc));
      pgui_item->name = XCAR (desc);
      desc = XCDR (desc);
      if (!NILP (desc))
	CHECK_CONS (desc);
    }

  /* Walk along all key-value pairs */
  while (!NILP(desc) && KEYWORDP (XCAR (desc)))
    {
      Lisp_Object key, val;
      key = XCAR (desc);
      desc = XCDR (desc);
      CHECK_CONS (desc);
      val = XCAR (desc);
      desc = XCDR (desc);
      if (!NILP (desc))
	CHECK_CONS (desc);
      gui_item_add_keyval_pair (gui_item, key, val, ERROR_ME);
    }

  /* Return the rest - supposed to be a list of items */
  return desc;
}
Ejemplo n.º 6
0
/** Add a binding to recentmost frame of an env */
SCM_EXPORT ScmObj
scm_add_environment(ScmObj var, ScmObj val, ScmObj env)
{
    ScmObj frame, formals, actuals;
    DECLARE_INTERNAL_FUNCTION("scm_add_environment");

    SCM_ASSERT(IDENTIFIERP(var));
    SCM_ASSERT(VALID_ENVP(env));

    /* add (var, val) pair to recentmost frame of the env */
    if (NULLP(env)) {
        frame = CONS(LIST_1(var), LIST_1(val));
        env = LIST_1(frame);
    } else if (CONSP(env)) {
        frame = CAR(env);
        formals = CONS(var, CAR(frame));
        actuals = CONS(val, CDR(frame));
        SET_CAR(frame, formals);
        SET_CDR(frame, actuals);
    } else {
        SCM_NOTREACHED;
    }
    return env;
}
Ejemplo n.º 7
0
Archivo: w32menu.c Proyecto: 0xAX/emacs
static bool
is_simple_dialog (Lisp_Object contents)
{
  Lisp_Object options;
  Lisp_Object name, yes, no, other;

  if (!CONSP (contents))
    return false;
  options = XCDR (contents);

  yes = build_string ("Yes");
  no = build_string ("No");

  if (!CONSP (options))
    return false;

  name = XCAR (options);
  if (!CONSP (name))
    return false;
  name = XCAR (name);

  if (!NILP (Fstring_equal (name, yes)))
    other = no;
  else if (!NILP (Fstring_equal (name, no)))
    other = yes;
  else
    return false;

  options = XCDR (options);
  if (!CONSP (options))
    return false;

  name = XCAR (options);
  if (!CONSP (name))
    return false;
  name = XCAR (name);
  if (NILP (Fstring_equal (name, other)))
    return false;

  /* Check there are no more options.  */
  options = XCDR (options);
  return !(CONSP (options));
}
Ejemplo n.º 8
0
/* This is the callback function for arriving signals from
   g_file_monitor.  It shall create a Lisp event, and put it into
   Emacs input queue.  */
static gboolean
dir_monitor_callback (GFileMonitor *monitor,
		      GFile *file,
		      GFile *other_file,
		      GFileMonitorEvent event_type,
		      gpointer user_data)
{
  Lisp_Object symbol, monitor_object, watch_object, flags;
  char *name = g_file_get_parse_name (file);
  char *oname = other_file ? g_file_get_parse_name (other_file) : NULL;

  /* Determine event symbol.  */
  switch (event_type)
    {
    case G_FILE_MONITOR_EVENT_CHANGED:
      symbol = Qchanged;
      break;
    case G_FILE_MONITOR_EVENT_CHANGES_DONE_HINT:
      symbol = Qchanges_done_hint;
      break;
    case G_FILE_MONITOR_EVENT_DELETED:
      symbol = Qdeleted;
      break;
    case G_FILE_MONITOR_EVENT_CREATED:
      symbol = Qcreated;
      break;
    case G_FILE_MONITOR_EVENT_ATTRIBUTE_CHANGED:
      symbol = Qattribute_changed;
      break;
    case G_FILE_MONITOR_EVENT_PRE_UNMOUNT:
      symbol = Qpre_unmount;
      break;
    case G_FILE_MONITOR_EVENT_UNMOUNTED:
      symbol = Qunmounted;
      break;
    case G_FILE_MONITOR_EVENT_MOVED:
      symbol = Qmoved;
      break;
    default:
      goto cleanup;
    }

  /* Determine callback function.  */
  monitor_object = make_pointer_integer (monitor);
  eassert (INTEGERP (monitor_object));
  watch_object = assq_no_quit (monitor_object, watch_list);

  if (CONSP (watch_object))
    {
      struct input_event event;
      Lisp_Object otail = oname ? list1 (build_string (oname)) : Qnil;

      /* Check, whether event_type is expected.  */
      flags = XCAR (XCDR (XCDR (watch_object)));
      if ((!NILP (Fmember (Qchange, flags)) &&
	   !NILP (Fmember (symbol, list5 (Qchanged, Qchanges_done_hint,
					  Qdeleted, Qcreated, Qmoved)))) ||
	  (!NILP (Fmember (Qattribute_change, flags)) &&
	   ((EQ (symbol, Qattribute_changed)))))
	{
	  /* Construct an event.  */
	  EVENT_INIT (event);
	  event.kind = FILE_NOTIFY_EVENT;
	  event.frame_or_window = Qnil;
	  event.arg = list2 (Fcons (monitor_object,
				    Fcons (symbol,
					   Fcons (build_string (name),
						  otail))),
			     XCAR (XCDR (XCDR (XCDR (watch_object)))));

	  /* Store it into the input event queue.  */
	  kbd_buffer_store_event (&event);
	  // XD_DEBUG_MESSAGE ("%s", XD_OBJECT_TO_STRING (event.arg));
	}

      /* Cancel monitor if file or directory is deleted.  */
      if (!NILP (Fmember (symbol, list2 (Qdeleted, Qmoved))) &&
	  !g_file_monitor_is_cancelled (monitor))
	g_file_monitor_cancel (monitor);
    }

  /* Cleanup.  */
 cleanup:
  g_free (name);
  g_free (oname);

  return TRUE;
}
Ejemplo n.º 9
0
/* This is the callback function for arriving signals from
   g_file_monitor.  It shall create a Lisp event, and put it into
   Emacs input queue.  */
static gboolean
dir_monitor_callback (GFileMonitor *monitor,
		      GFile *file,
		      GFile *other_file,
		      GFileMonitorEvent event_type,
		      gpointer user_data)
{
  Lisp_Object symbol, monitor_object, watch_object;
  char *name = g_file_get_parse_name (file);
  char *oname = other_file ? g_file_get_parse_name (other_file) : NULL;

  /* Determine event symbol.  */
  switch (event_type)
    {
    case G_FILE_MONITOR_EVENT_CHANGED:
      symbol = Qchanged;
      break;
    case G_FILE_MONITOR_EVENT_CHANGES_DONE_HINT:
      symbol = Qchanges_done_hint;
      break;
    case G_FILE_MONITOR_EVENT_DELETED:
      symbol = Qdeleted;
      break;
    case G_FILE_MONITOR_EVENT_CREATED:
      symbol = Qcreated;
      break;
    case G_FILE_MONITOR_EVENT_ATTRIBUTE_CHANGED:
      symbol = Qattribute_changed;
      break;
    case G_FILE_MONITOR_EVENT_PRE_UNMOUNT:
      symbol = Qpre_unmount;
      break;
    case G_FILE_MONITOR_EVENT_UNMOUNTED:
      symbol = Qunmounted;
      break;
    case G_FILE_MONITOR_EVENT_MOVED:
      symbol = Qmoved;
      break;
    default:
      goto cleanup;
    }

  /* Determine callback function.  */
  monitor_object = XIL ((intptr_t) monitor);
  eassert (INTEGERP (monitor_object));
  watch_object = assq_no_quit (monitor_object, watch_list);

  if (CONSP (watch_object))
    {
      /* Construct an event.  */
      struct input_event event;
      Lisp_Object otail = oname ? list1 (build_string (oname)) : Qnil;
      EVENT_INIT (event);
      event.kind = FILE_NOTIFY_EVENT;
      event.frame_or_window = Qnil;
      event.arg = list2 (Fcons (monitor_object,
				Fcons (symbol,
				       Fcons (build_string (name),
					      otail))),
			 XCDR (watch_object));

      /* Store it into the input event queue.  */
      kbd_buffer_store_event (&event);
    }

  /* Cleanup.  */
 cleanup:
  g_free (name);
  g_free (oname);

  return TRUE;
}
Ejemplo n.º 10
0
int
update_window_fringes (struct window *w, int keep_current_p)
{
  struct glyph_row *row, *cur = 0;
  int yb = window_text_bottom_y (w);
  int rn, nrows = w->current_matrix->nrows;
  int y;
  int redraw_p = 0;
  Lisp_Object boundary_top = Qnil, boundary_bot = Qnil;
  Lisp_Object arrow_top = Qnil, arrow_bot = Qnil;
  Lisp_Object empty_pos;
  Lisp_Object ind = Qnil;
#define MAX_BITMAP_CACHE (8*4)
  int bitmap_cache[MAX_BITMAP_CACHE];
  int top_ind_rn, bot_ind_rn;
  int top_ind_min_y, bot_ind_max_y;

  /* top_ind_rn is set to a nonnegative value whenver
     row->indicate_bob_p is set, so it's OK that top_row_ends_at_zv_p
     is not initialized here.  Similarly for bot_ind_rn,
     row->indicate_eob_p and bot_row_ends_at_zv_p.  */
  int top_row_ends_at_zv_p IF_LINT (= 0), bot_row_ends_at_zv_p IF_LINT (= 0);

  if (w->pseudo_window_p)
    return 0;

  if (!MINI_WINDOW_P (w)
      && (ind = BVAR (XBUFFER (w->buffer), indicate_buffer_boundaries), !NILP (ind)))
    {
      if (EQ (ind, Qleft) || EQ (ind, Qright))
	boundary_top = boundary_bot = arrow_top = arrow_bot = ind;
      else if (CONSP (ind) && CONSP (XCAR (ind)))
	{
	  Lisp_Object pos;
	  if (pos = Fassq (Qt, ind), !NILP (pos))
	    boundary_top = boundary_bot = arrow_top = arrow_bot = XCDR (pos);
	  if (pos = Fassq (Qtop, ind), !NILP (pos))
	    boundary_top = XCDR (pos);
	  if (pos = Fassq (Qbottom, ind), !NILP (pos))
	    boundary_bot = XCDR (pos);
	  if (pos = Fassq (Qup, ind), !NILP (pos))
	    arrow_top = XCDR (pos);
	  if (pos = Fassq (Qdown, ind), !NILP (pos))
	    arrow_bot = XCDR (pos);
	}
      else
	/* Anything else means boundary on left and no arrows.  */
	boundary_top = boundary_bot = Qleft;
    }

  top_ind_rn = bot_ind_rn = -1;
  if (!NILP (ind))
    {
      for (y = w->vscroll, rn = 0;
	   y < yb && rn < nrows;
	   y += row->height, ++rn)
	{
	  row = w->desired_matrix->rows + rn;
	  if (!row->enabled_p)
	    row = w->current_matrix->rows + rn;

	  row->indicate_bob_p = row->indicate_top_line_p = 0;
	  row->indicate_eob_p = row->indicate_bottom_line_p = 0;

	  if (!row->mode_line_p)
	    {
	      if (top_ind_rn < 0 && row->visible_height > 0)
		{
		  if (MATRIX_ROW_START_CHARPOS (row) <= BUF_BEGV (XBUFFER (w->buffer))
		      && !MATRIX_ROW_PARTIALLY_VISIBLE_AT_TOP_P (w, row))
		    row->indicate_bob_p = !NILP (boundary_top);
		  else
		    row->indicate_top_line_p = !NILP (arrow_top);
		  top_ind_rn = rn;
		}

	      if (bot_ind_rn < 0)
		{
		  if (MATRIX_ROW_END_CHARPOS (row) >= BUF_ZV (XBUFFER (w->buffer))
		      && !MATRIX_ROW_PARTIALLY_VISIBLE_AT_BOTTOM_P (w, row))
		    row->indicate_eob_p = !NILP (boundary_bot), bot_ind_rn = rn;
		  else if (y + row->height >= yb)
		    row->indicate_bottom_line_p = !NILP (arrow_bot), bot_ind_rn = rn;
		}
	    }
	}
    }

  empty_pos = BVAR (XBUFFER (w->buffer), indicate_empty_lines);
  if (!NILP (empty_pos) && !EQ (empty_pos, Qright))
    empty_pos = WINDOW_LEFT_FRINGE_WIDTH (w) == 0 ? Qright : Qleft;

  for (y = 0; y < MAX_BITMAP_CACHE; y++)
    bitmap_cache[y] = -1;

#define LEFT_FRINGE(cache, which, partial_p)			\
  (bitmap_cache[cache*4+partial_p] >= 0				\
   ? bitmap_cache[cache*4+partial_p]				\
   : (bitmap_cache[cache*4+partial_p] =				\
      get_logical_fringe_bitmap (w, which, 0, partial_p)))

#define RIGHT_FRINGE(cache, which, partial_p)			\
  (bitmap_cache[cache*4+2+partial_p] >= 0			\
   ? bitmap_cache[cache*4+2+partial_p]				\
   : (bitmap_cache[cache*4+2+partial_p] =			\
      get_logical_fringe_bitmap (w, which, 1, partial_p)))


  /* Extend top-aligned top indicator (or bottom-aligned bottom
     indicator) to adjacent rows if it doesn't fit in one row.  */
  top_ind_min_y = bot_ind_max_y = -1;
  if (top_ind_rn >= 0)
    {
      int bn = NO_FRINGE_BITMAP;

      row = w->desired_matrix->rows + top_ind_rn;
      if (!row->enabled_p)
	row = w->current_matrix->rows + top_ind_rn;

      top_row_ends_at_zv_p = row->ends_at_zv_p;
      if (row->indicate_bob_p)
	{
	  if (EQ (boundary_top, Qleft))
	    bn = ((row->indicate_eob_p && EQ (boundary_bot, Qleft))
		  ? LEFT_FRINGE (1, Qtop_bottom, row->ends_at_zv_p)
		  : LEFT_FRINGE (2, Qtop, 0));
	  else
	    bn = ((row->indicate_eob_p && EQ (boundary_bot, Qright))
		  ? RIGHT_FRINGE (1, Qtop_bottom, row->ends_at_zv_p)
		  : RIGHT_FRINGE (2, Qtop, 0));
	}
      else if (row->indicate_top_line_p)
	{
	  if (EQ (arrow_top, Qleft))
	    bn = LEFT_FRINGE (6, Qup, 0);
	  else
	    bn = RIGHT_FRINGE (6, Qup, 0);
	}

      if (bn != NO_FRINGE_BITMAP)
	{
	  struct fringe_bitmap *fb = get_fringe_bitmap_data (bn);

	  if (fb->align == ALIGN_BITMAP_TOP && fb->period == 0)
	    {
	      struct glyph_row *row1;
	      int top_ind_max_y;

	      top_ind_min_y = WINDOW_HEADER_LINE_HEIGHT (w);
	      top_ind_max_y = top_ind_min_y + fb->height;
	      if (top_ind_max_y > yb)
		top_ind_max_y = yb;

	      for (y = row->y + row->height, rn = top_ind_rn + 1;
		   y < top_ind_max_y && rn < nrows;
		   y += row1->height, rn++)
		{
		  if (bot_ind_rn >= 0 && rn >= bot_ind_rn)
		    break;

		  row1 = w->desired_matrix->rows + rn;
		  if (!row1->enabled_p)
		    row1 = w->current_matrix->rows + rn;

		  row1->indicate_bob_p = row->indicate_bob_p;
		  row1->indicate_top_line_p = row->indicate_top_line_p;
		}
	    }
	}
    }
  if (bot_ind_rn >= 0)
    {
      int bn = NO_FRINGE_BITMAP;

      row = w->desired_matrix->rows + bot_ind_rn;
      if (!row->enabled_p)
	row = w->current_matrix->rows + bot_ind_rn;

      bot_row_ends_at_zv_p = row->ends_at_zv_p;
      if (row->indicate_eob_p)
	{
	  if (EQ (boundary_bot, Qleft))
	    bn = LEFT_FRINGE (3, Qbottom, row->ends_at_zv_p);
	  else
	    bn = RIGHT_FRINGE (3, Qbottom, row->ends_at_zv_p);
	}
      else if (row->indicate_bottom_line_p)
	{
	  if (EQ (arrow_bot, Qleft))
	    bn = LEFT_FRINGE (7, Qdown, 0);
	  else
	    bn = RIGHT_FRINGE (7, Qdown, 0);
	}

      if (bn != NO_FRINGE_BITMAP)
	{
	  struct fringe_bitmap *fb = get_fringe_bitmap_data (bn);

	  if (fb->align == ALIGN_BITMAP_BOTTOM && fb->period == 0)
	    {
	      struct glyph_row *row1;
	      int bot_ind_min_y;

	      bot_ind_max_y = row->y + row->visible_height;
	      bot_ind_min_y = bot_ind_max_y - fb->height;
	      if (bot_ind_min_y < WINDOW_HEADER_LINE_HEIGHT (w))
		bot_ind_min_y = WINDOW_HEADER_LINE_HEIGHT (w);

	      for (y = row->y, rn = bot_ind_rn - 1;
		   y >= bot_ind_min_y && rn >= 0;
		   y -= row1->height, rn--)
		{
		  if (top_ind_rn >= 0 && rn <= top_ind_rn)
		    break;

		  row1 = w->desired_matrix->rows + rn;
		  if (!row1->enabled_p)
		    row1 = w->current_matrix->rows + rn;

		  row1->indicate_eob_p = row->indicate_eob_p;
		  row1->indicate_bottom_line_p = row->indicate_bottom_line_p;
		}
	    }
	}
    }

  for (y = w->vscroll, rn = 0;
       y < yb && rn < nrows;
       y += row->height, rn++)
    {
      int left, right;
      unsigned left_face_id, right_face_id;
      int left_offset, right_offset;
      int periodic_p;

      row = w->desired_matrix->rows + rn;
      cur = w->current_matrix->rows + rn;
      if (!row->enabled_p)
	row = cur;

      left_face_id = right_face_id = DEFAULT_FACE_ID;
      left_offset = right_offset = 0;
      periodic_p = 0;

      /* Decide which bitmap to draw in the left fringe.  */
      if (WINDOW_LEFT_FRINGE_WIDTH (w) == 0)
	left = NO_FRINGE_BITMAP;
      else if (row->left_user_fringe_bitmap != NO_FRINGE_BITMAP)
	{
	  left = row->left_user_fringe_bitmap;
	  left_face_id = row->left_user_fringe_face_id;
	}
      else if ((!row->reversed_p && row->truncated_on_left_p)
	       || (row->reversed_p && row->truncated_on_right_p))
	left = LEFT_FRINGE (0, Qtruncation, 0);
      else if (row->indicate_bob_p && EQ (boundary_top, Qleft))
	{
	  left = ((row->indicate_eob_p && EQ (boundary_bot, Qleft))
		  ? LEFT_FRINGE (1, Qtop_bottom, top_row_ends_at_zv_p)
		  : LEFT_FRINGE (2, Qtop, 0));
	  if (top_ind_min_y >= 0)
	    left_offset = top_ind_min_y - row->y;
	}
      else if (row->indicate_eob_p && EQ (boundary_bot, Qleft))
	{
	  left = LEFT_FRINGE (3, Qbottom, bot_row_ends_at_zv_p);
	  if (bot_ind_max_y >= 0)
	    left_offset = bot_ind_max_y - (row->y + row->visible_height);
	}
      else if ((!row->reversed_p && MATRIX_ROW_CONTINUATION_LINE_P (row))
	       || (row->reversed_p && row->continued_p))
	left = LEFT_FRINGE (4, Qcontinuation, 0);
      else if (row->indicate_empty_line_p && EQ (empty_pos, Qleft))
	left = LEFT_FRINGE (5, Qempty_line, 0);
      else if (row->indicate_top_line_p && EQ (arrow_top, Qleft))
	{
	  left = LEFT_FRINGE (6, Qup, 0);
	  if (top_ind_min_y >= 0)
	    left_offset = top_ind_min_y - row->y;
	}
      else if (row->indicate_bottom_line_p && EQ (arrow_bot, Qleft))
	{
	  left = LEFT_FRINGE (7, Qdown, 0);
	  if (bot_ind_max_y >= 0)
	    left_offset = bot_ind_max_y - (row->y + row->visible_height);
	}
      else
	left = NO_FRINGE_BITMAP;

      /* Decide which bitmap to draw in the right fringe.  */
      if (WINDOW_RIGHT_FRINGE_WIDTH (w) == 0)
	right = NO_FRINGE_BITMAP;
      else if (row->right_user_fringe_bitmap != NO_FRINGE_BITMAP)
	{
	  right = row->right_user_fringe_bitmap;
	  right_face_id = row->right_user_fringe_face_id;
	}
      else if ((!row->reversed_p && row->truncated_on_right_p)
	       || (row->reversed_p && row->truncated_on_left_p))
	right = RIGHT_FRINGE (0, Qtruncation, 0);
      else if (row->indicate_bob_p && EQ (boundary_top, Qright))
	{
	  right = ((row->indicate_eob_p && EQ (boundary_bot, Qright))
		   ? RIGHT_FRINGE (1, Qtop_bottom, top_row_ends_at_zv_p)
		   : RIGHT_FRINGE (2, Qtop, 0));
	  if (top_ind_min_y >= 0)
	    right_offset = top_ind_min_y - row->y;
	}
      else if (row->indicate_eob_p && EQ (boundary_bot, Qright))
	{
	  right = RIGHT_FRINGE (3, Qbottom, bot_row_ends_at_zv_p);
	  if (bot_ind_max_y >= 0)
	    right_offset = bot_ind_max_y - (row->y + row->visible_height);
	}
      else if ((!row->reversed_p && row->continued_p)
	       || (row->reversed_p && MATRIX_ROW_CONTINUATION_LINE_P (row)))
	right = RIGHT_FRINGE (4, Qcontinuation, 0);
      else if (row->indicate_top_line_p && EQ (arrow_top, Qright))
	{
	  right = RIGHT_FRINGE (6, Qup, 0);
	  if (top_ind_min_y >= 0)
	    right_offset = top_ind_min_y - row->y;
	}
      else if (row->indicate_bottom_line_p && EQ (arrow_bot, Qright))
	{
	  right = RIGHT_FRINGE (7, Qdown, 0);
	  if (bot_ind_max_y >= 0)
	    right_offset = bot_ind_max_y - (row->y + row->visible_height);
	}
      else if (row->indicate_empty_line_p && EQ (empty_pos, Qright))
	right = RIGHT_FRINGE (5, Qempty_line, 0);
      else
	right = NO_FRINGE_BITMAP;

      periodic_p = (get_fringe_bitmap_data (left)->period != 0
		    || get_fringe_bitmap_data (right)->period != 0);

      if (row->y != cur->y
	  || row->visible_height != cur->visible_height
	  || row->ends_at_zv_p != cur->ends_at_zv_p
	  || left != cur->left_fringe_bitmap
	  || right != cur->right_fringe_bitmap
	  || left_face_id != cur->left_fringe_face_id
	  || right_face_id != cur->right_fringe_face_id
	  || left_offset != cur->left_fringe_offset
	  || right_offset != cur->right_fringe_offset
	  || periodic_p != cur->fringe_bitmap_periodic_p
	  || cur->redraw_fringe_bitmaps_p)
	{
	  redraw_p = row->redraw_fringe_bitmaps_p = 1;
	  if (!keep_current_p)
	    {
	      cur->redraw_fringe_bitmaps_p = 1;
	      cur->left_fringe_bitmap = left;
	      cur->right_fringe_bitmap = right;
	      cur->left_fringe_face_id = left_face_id;
	      cur->right_fringe_face_id = right_face_id;
	      cur->left_fringe_offset = left_offset;
	      cur->right_fringe_offset = right_offset;
	      cur->fringe_bitmap_periodic_p = periodic_p;
	    }
	}

      if (row->overlay_arrow_bitmap < 0)
	row->overlay_arrow_bitmap = get_logical_fringe_bitmap (w, Qoverlay_arrow, 0, 0);

      if (row->overlay_arrow_bitmap != cur->overlay_arrow_bitmap)
	{
	  redraw_p = row->redraw_fringe_bitmaps_p = 1;
	  if (!keep_current_p)
	    {
	      cur->redraw_fringe_bitmaps_p = 1;
	      cur->overlay_arrow_bitmap = row->overlay_arrow_bitmap;
	    }
	}

      row->left_fringe_bitmap = left;
      row->right_fringe_bitmap = right;
      row->left_fringe_face_id = left_face_id;
      row->right_fringe_face_id = right_face_id;
      row->left_fringe_offset = left_offset;
      row->right_fringe_offset = right_offset;
      row->fringe_bitmap_periodic_p = periodic_p;
    }

  return redraw_p && !keep_current_p;
}
Ejemplo n.º 11
0
static int
handle_file_notifications (struct input_event *hold_quit)
{
  BYTE *p = file_notifications;
  FILE_NOTIFY_INFORMATION *fni = (PFILE_NOTIFY_INFORMATION)p;
  const DWORD min_size
    = offsetof (FILE_NOTIFY_INFORMATION, FileName) + sizeof(wchar_t);
  struct input_event inev;
  int nevents = 0;

  /* We cannot process notification before Emacs is fully initialized,
     since we need the UTF-16LE coding-system to be set up.  */
  if (!initialized)
    {
      notification_buffer_in_use = 0;
      return nevents;
    }

  enter_crit ();
  if (notification_buffer_in_use)
    {
      DWORD info_size = notifications_size;
      Lisp_Object cs = intern ("utf-16le");
      Lisp_Object obj = w32_get_watch_object (notifications_desc);

      /* notifications_size could be zero when the buffer of
	 notifications overflowed on the OS level, or when the
	 directory being watched was itself deleted.  Do nothing in
	 that case.  */
      if (info_size
	  && !NILP (obj) && CONSP (obj))
	{
	  Lisp_Object callback = XCDR (obj);

	  EVENT_INIT (inev);

	  while (info_size >= min_size)
	    {
	      Lisp_Object utf_16_fn
		= make_unibyte_string ((char *)fni->FileName,
				       fni->FileNameLength);
	      /* Note: mule-conf is preloaded, so utf-16le must
		 already be defined at this point.  */
	      Lisp_Object fname
		= code_convert_string_norecord (utf_16_fn, cs, 0);
	      Lisp_Object action = lispy_file_action (fni->Action);

	      inev.kind = FILE_NOTIFY_EVENT;
	      inev.code = (ptrdiff_t)XINT (XIL ((EMACS_INT)notifications_desc));
	      inev.timestamp = GetTickCount ();
	      inev.modifiers = 0;
	      inev.frame_or_window = callback;
	      inev.arg = Fcons (action, fname);
	      kbd_buffer_store_event_hold (&inev, hold_quit);

	      if (!fni->NextEntryOffset)
		break;
	      p += fni->NextEntryOffset;
	      fni = (PFILE_NOTIFY_INFORMATION)p;
	      info_size -= fni->NextEntryOffset;
	    }
	}
      notification_buffer_in_use = 0;
    }
  leave_crit ();
  return nevents;
}
Ejemplo n.º 12
0
static lref_t execute_fast_op(lref_t fop, lref_t env)
{
     lref_t retval = NIL;
     lref_t sym;
     lref_t binding;
     lref_t fn;
     lref_t args;
     size_t argc;
     lref_t argv[ARG_BUF_LEN];
     lref_t after;
     lref_t tag;
     lref_t cell;
     lref_t escape_retval;
     jmp_buf *jmpbuf;

     STACK_CHECK(&fop);
     _process_interrupts();

     fstack_enter_eval_frame(&fop, fop, env);

     while(!NULLP(fop)) {
          switch(fop->header.opcode)
          {
          case FOP_LITERAL:
               retval = fop->as.fast_op.arg1;
               fop = fop->as.fast_op.next;
               break;

          case FOP_GLOBAL_REF:
               sym = fop->as.fast_op.arg1;
               binding = SYMBOL_VCELL(sym);

               if (UNBOUND_MARKER_P(binding))
                    vmerror_unbound(sym);

               retval = binding;

               fop = fop->as.fast_op.next;
               break;

          case FOP_GLOBAL_SET:
               sym = fop->as.fast_op.arg1;
               binding = SYMBOL_VCELL(sym);

               if (UNBOUND_MARKER_P(binding))
                    vmerror_unbound(sym);

               SET_SYMBOL_VCELL(sym, retval);

               fop = fop->as.fast_op.next;
               break;

          case FOP_APPLY_GLOBAL:
               sym = fop->as.fast_op.arg1;
               fn = SYMBOL_VCELL(sym);

               if (UNBOUND_MARKER_P(fn))
                    vmerror_unbound(sym);

               argc = 0;
               args = fop->as.fast_op.arg2;

               while (CONSP(args)) {
                    if (argc >= ARG_BUF_LEN) {
                         vmerror_unsupported(_T("too many actual arguments"));
                         break;
                    }

                    argv[argc] = execute_fast_op(CAR(args), env);

                    args = CDR(args);
                    argc++;
               }

               if (!NULLP(args))
                    vmerror_arg_out_of_range(fop->as.fast_op.arg2,
                                             _T("bad formal argument list"));

               fop = apply(fn, argc, argv, &env, &retval);
               break;

          case FOP_APPLY:
               argc = 0;
               fn = execute_fast_op(fop->as.fast_op.arg1, env);
               args = fop->as.fast_op.arg2;

               while (CONSP(args)) {
                    if (argc >= ARG_BUF_LEN) {
                         vmerror_unsupported(_T("too many actual arguments"));
                         break;
                    }

                    argv[argc] = execute_fast_op(CAR(args), env);

                    args = CDR(args);
                    argc++;
               }

               if (!NULLP(args))
                    vmerror_arg_out_of_range(fop->as.fast_op.arg2,
                                             _T("bad formal argument list"));

               fop = apply(fn, argc, argv, &env, &retval);
               break;

          case FOP_IF_TRUE:
               if (TRUEP(retval))
                    fop = fop->as.fast_op.arg1;
               else
                    fop = fop->as.fast_op.arg2;
               break;

          case FOP_RETVAL:
               fop = fop->as.fast_op.next;
               break;

          case FOP_SEQUENCE:
               retval = execute_fast_op(fop->as.fast_op.arg1, env);

               fop = fop->as.fast_op.arg2;
               break;

          case FOP_THROW:
               tag = execute_fast_op(fop->as.fast_op.arg1, env);
               escape_retval = execute_fast_op(fop->as.fast_op.arg2, env);

               dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: throw ~a, retval = ~a\n"), tag, escape_retval));

               CURRENT_TIB()->escape_frame = find_matching_escape(CURRENT_TIB()->frame, tag);
               CURRENT_TIB()->escape_value = escape_retval;

               if (CURRENT_TIB()->escape_frame == NULL) {
                    /* If we don't find a matching catch for the throw, we have a
                     * problem and need to invoke a trap. */
                    vmtrap(TRAP_UNCAUGHT_THROW,
                           (enum vmt_options_t)(VMT_MANDATORY_TRAP | VMT_HANDLER_MUST_ESCAPE),
                           2, tag, escape_retval);
               }

               unwind_stack_for_throw();

               fop = fop->as.fast_op.next;
               break;

          case FOP_CATCH:
               tag = execute_fast_op(fop->as.fast_op.arg1, env);

               jmpbuf = fstack_enter_catch_frame(tag, CURRENT_TIB()->frame);

               dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: setjmp tag: ~a, frame: ~c&, jmpbuf: ~c&\n"), tag, CURRENT_TIB()->frame, jmpbuf));

               if (setjmp(*jmpbuf) == 0) {
                    retval = execute_fast_op(fop->as.fast_op.arg2, env);
               } else {
                    dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: catch, retval = ~a\n"), CURRENT_TIB()->escape_value));

                    retval = CURRENT_TIB()->escape_value;
                    CURRENT_TIB()->escape_value = NIL;
               }

               fstack_leave_frame();

               fop = fop->as.fast_op.next;
               break;

          case FOP_WITH_UNWIND_FN:
               fstack_enter_unwind_frame(execute_fast_op(fop->as.fast_op.arg1, env));

               retval = execute_fast_op(fop->as.fast_op.arg2, env);

               after = CURRENT_TIB()->frame[FOFS_UNWIND_AFTER];

               fstack_leave_frame();

               apply1(after, 0, NULL);

               fop = fop->as.fast_op.next;
               break;

          case FOP_CLOSURE:
               retval = lclosurecons(env,
                                     lcons(lcar(fop->as.fast_op.arg1),
                                           fop->as.fast_op.arg2),
                                     lcdr(fop->as.fast_op.arg1));
               fop = fop->as.fast_op.next;
               break;

          case FOP_CAR:
               retval = lcar(retval);
               fop = fop->as.fast_op.next;
               break;

          case FOP_CDR:
               retval = lcdr(retval);
               fop = fop->as.fast_op.next;
               break;

          case FOP_NOT:
               retval = boolcons(!TRUEP(retval));
               fop = fop->as.fast_op.next;
               break;

          case FOP_NULLP:
               retval = boolcons(NULLP(retval));
               fop = fop->as.fast_op.next;
               break;

          case FOP_EQP:
               retval = boolcons(EQ(execute_fast_op(fop->as.fast_op.arg1, env),
                                    execute_fast_op(fop->as.fast_op.arg2, env)));
               fop = fop->as.fast_op.next;
               break;

          case FOP_GET_ENV:
               retval = env;
               fop = fop->as.fast_op.next;
               break;

          case FOP_GLOBAL_DEF: // three args, third was genv, but currently unused
               retval = lidefine_global(fop->as.fast_op.arg1, fop->as.fast_op.arg2);
               fop = fop->as.fast_op.next;
               break;

          case FOP_GET_FSP:
               retval = fixcons((fixnum_t)CURRENT_TIB()->fsp);
               fop = fop->as.fast_op.next;
               break;

          case FOP_GET_FRAME:
               retval = fixcons((fixnum_t)CURRENT_TIB()->frame);
               fop = fop->as.fast_op.next;
               break;

          case FOP_GET_HFRAMES:
               retval = CURRENT_TIB()->handler_frames;
               fop = fop->as.fast_op.next;
               break;

          case FOP_SET_HFRAMES:
               CURRENT_TIB()->handler_frames = execute_fast_op(fop->as.fast_op.arg1, env);
               fop = fop->as.fast_op.next;
               break;

          case FOP_GLOBAL_PRESERVE_FRAME:
               sym = fop->as.fast_op.arg1;
               binding = SYMBOL_VCELL(sym);

               if (UNBOUND_MARKER_P(binding))
                    vmerror_unbound(sym);

               SET_SYMBOL_VCELL(sym, fixcons((fixnum_t)CURRENT_TIB()->frame));

               retval = execute_fast_op(fop->as.fast_op.arg2, env);
               fop = fop->as.fast_op.next;
               break;

          case FOP_STACK_BOUNDARY:
               sym = execute_fast_op(fop->as.fast_op.arg1, env);

               fstack_enter_boundary_frame(sym);

               retval = execute_fast_op(fop->as.fast_op.arg2, env);

               fstack_leave_frame();

               fop = fop->as.fast_op.next;
               break;

          case FOP_FAST_ENQUEUE_CELL:
               retval = execute_fast_op(fop->as.fast_op.arg2, env);

               cell = execute_fast_op(fop->as.fast_op.arg1, env);

               SET_CDR(CAR(retval), cell);
               SET_CAR(retval, cell);

               fop = fop->as.fast_op.next;
               break;

          case FOP_WHILE_TRUE:
               while(TRUEP(execute_fast_op(fop->as.fast_op.arg1, env))) {
                    retval = execute_fast_op(fop->as.fast_op.arg2, env);
               }
               fop = fop->as.fast_op.next;
               break;

          case FOP_LOCAL_REF_BY_INDEX:
               retval = lenvlookup_by_index(FIXNM(fop->as.fast_op.arg1),
                                            FIXNM(fop->as.fast_op.arg2),
                                            env);
               fop = fop->as.fast_op.next;
               break;

          case FOP_LOCAL_REF_RESTARG:
               retval = lenvlookup_restarg_by_index(FIXNM(fop->as.fast_op.arg1),
                                                    FIXNM(fop->as.fast_op.arg2),
                                                    env);
               fop = fop->as.fast_op.next;
               break;

          case FOP_LOCAL_SET_BY_INDEX:
               lenvlookup_set_by_index(FIXNM(fop->as.fast_op.arg1),
                                       FIXNM(fop->as.fast_op.arg2),
                                       env,
                                       retval);
               fop = fop->as.fast_op.next;
               break;

          default:
               panic("Unsupported fast-op");
          }
     }

     fstack_leave_frame();

     return retval;
}
Ejemplo n.º 13
0
Lisp_Object
get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
{
  char *from, *to, *name, *p, *p1;
  int fd;
  int offset;
  EMACS_INT position;
  Lisp_Object file, tem, pos;
  ptrdiff_t count;
  USE_SAFE_ALLOCA;

  if (INTEGERP (filepos))
    {
      file = Vdoc_file_name;
      pos = filepos;
    }
  else if (CONSP (filepos))
    {
      file = XCAR (filepos);
      pos = XCDR (filepos);
    }
  else
    return Qnil;

  position = eabs (XINT (pos));

  if (!STRINGP (Vdoc_directory))
    return Qnil;

  if (!STRINGP (file))
    return Qnil;

  /* Put the file name in NAME as a C string.
     If it is relative, combine it with Vdoc_directory.  */

  tem = Ffile_name_absolute_p (file);
  file = ENCODE_FILE (file);
  Lisp_Object docdir
    = NILP (tem) ? ENCODE_FILE (Vdoc_directory) : empty_unibyte_string;
  ptrdiff_t docdir_sizemax = SBYTES (docdir) + 1;
#ifndef CANNOT_DUMP
  docdir_sizemax = max (docdir_sizemax, sizeof sibling_etc);
#endif
  name = SAFE_ALLOCA (docdir_sizemax + SBYTES (file));
  lispstpcpy (lispstpcpy (name, docdir), file);

  fd = emacs_open (name, O_RDONLY, 0);
  if (fd < 0)
    {
#ifndef CANNOT_DUMP
      if (!NILP (Vpurify_flag))
	{
	  /* Preparing to dump; DOC file is probably not installed.
	     So check in ../etc.  */
	  lispstpcpy (stpcpy (name, sibling_etc), file);

	  fd = emacs_open (name, O_RDONLY, 0);
	}
#endif
      if (fd < 0)
	{
	  if (errno == EMFILE || errno == ENFILE)
	    report_file_error ("Read error on documentation file", file);

	  SAFE_FREE ();
	  AUTO_STRING (cannot_open, "Cannot open doc string file \"");
	  AUTO_STRING (quote_nl, "\"\n");
	  return concat3 (cannot_open, file, quote_nl);
	}
    }
  count = SPECPDL_INDEX ();
  record_unwind_protect_int (close_file_unwind, fd);

  /* Seek only to beginning of disk block.  */
  /* Make sure we read at least 1024 bytes before `position'
     so we can check the leading text for consistency.  */
  offset = min (position, max (1024, position % (8 * 1024)));
  if (TYPE_MAXIMUM (off_t) < position
      || lseek (fd, position - offset, 0) < 0)
    error ("Position %"pI"d out of range in doc string file \"%s\"",
	   position, name);

  /* Read the doc string into get_doc_string_buffer.
     P points beyond the data just read.  */

  p = get_doc_string_buffer;
  while (1)
    {
      ptrdiff_t space_left = (get_doc_string_buffer_size - 1
			      - (p - get_doc_string_buffer));
      int nread;

      /* Allocate or grow the buffer if we need to.  */
      if (space_left <= 0)
	{
	  ptrdiff_t in_buffer = p - get_doc_string_buffer;
	  get_doc_string_buffer
	    = xpalloc (get_doc_string_buffer, &get_doc_string_buffer_size,
		       16 * 1024, -1, 1);
	  p = get_doc_string_buffer + in_buffer;
	  space_left = (get_doc_string_buffer_size - 1
			- (p - get_doc_string_buffer));
	}

      /* Read a disk block at a time.
         If we read the same block last time, maybe skip this?  */
      if (space_left > 1024 * 8)
	space_left = 1024 * 8;
      nread = emacs_read (fd, p, space_left);
      if (nread < 0)
	report_file_error ("Read error on documentation file", file);
      p[nread] = 0;
      if (!nread)
	break;
      if (p == get_doc_string_buffer)
	p1 = strchr (p + offset, '\037');
      else
	p1 = strchr (p, '\037');
      if (p1)
	{
	  *p1 = 0;
	  p = p1;
	  break;
	}
      p += nread;
    }
  unbind_to (count, Qnil);
  SAFE_FREE ();

  /* Sanity checking.  */
  if (CONSP (filepos))
    {
      int test = 1;
      /* A dynamic docstring should be either at the very beginning of a "#@
	 comment" or right after a dynamic docstring delimiter (in case we
	 pack several such docstrings within the same comment).  */
      if (get_doc_string_buffer[offset - test] != '\037')
	{
	  if (get_doc_string_buffer[offset - test++] != ' ')
	    return Qnil;
	  while (get_doc_string_buffer[offset - test] >= '0'
		 && get_doc_string_buffer[offset - test] <= '9')
	    test++;
	  if (get_doc_string_buffer[offset - test++] != '@'
	      || get_doc_string_buffer[offset - test] != '#')
	    return Qnil;
	}
    }
  else
    {
      int test = 1;
      if (get_doc_string_buffer[offset - test++] != '\n')
	return Qnil;
      while (get_doc_string_buffer[offset - test] > ' ')
	test++;
      if (get_doc_string_buffer[offset - test] != '\037')
	return Qnil;
    }

  /* Scan the text and perform quoting with ^A (char code 1).
     ^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_.  */
  from = get_doc_string_buffer + offset;
  to = get_doc_string_buffer + offset;
  while (from != p)
    {
      if (*from == 1)
	{
	  int c;

	  from++;
	  c = *from++;
	  if (c == 1)
	    *to++ = c;
	  else if (c == '0')
	    *to++ = 0;
	  else if (c == '_')
	    *to++ = 037;
	  else
	    {
	      unsigned char uc = c;
	      error ("\
Invalid data in documentation file -- %c followed by code %03o",
		     1, uc);
	    }
	}
      else
	*to++ = *from++;
    }

  /* If DEFINITION, read from this buffer
     the same way we would read bytes from a file.  */
  if (definition)
    {
      read_bytecode_pointer = (unsigned char *) get_doc_string_buffer + offset;
      return Fread (Qlambda);
    }

  if (unibyte)
    return make_unibyte_string (get_doc_string_buffer + offset,
				to - (get_doc_string_buffer + offset));
  else
    {
      /* The data determines whether the string is multibyte.  */
      ptrdiff_t nchars
	= multibyte_chars_in_text (((unsigned char *) get_doc_string_buffer
				    + offset),
				   to - (get_doc_string_buffer + offset));
      return make_string_from_bytes (get_doc_string_buffer + offset,
				     nchars,
				     to - (get_doc_string_buffer + offset));
    }
}
Ejemplo n.º 14
0
static void
fix_command (Lisp_Object input, Lisp_Object values)
{
  /* FIXME: Instead of this ugly hack, we should provide a way for an
     interactive spec to return an expression/function that will re-build the
     args without user intervention.  */
  if (CONSP (input))
    {
      Lisp_Object car;

      car = XCAR (input);
      /* Skip through certain special forms.  */
      while (EQ (car, Qlet) || EQ (car, Qletx)
	     || EQ (car, Qsave_excursion)
	     || EQ (car, Qprogn))
	{
	  while (CONSP (XCDR (input)))
	    input = XCDR (input);
	  input = XCAR (input);
	  if (!CONSP (input))
	    break;
	  car = XCAR (input);
	}
      if (EQ (car, Qlist))
	{
	  Lisp_Object intail, valtail;
	  for (intail = Fcdr (input), valtail = values;
	       CONSP (valtail);
	       intail = Fcdr (intail), valtail = XCDR (valtail))
	    {
	      Lisp_Object elt;
	      elt = Fcar (intail);
	      if (CONSP (elt))
		{
		  Lisp_Object presflag, carelt;
		  carelt = XCAR (elt);
		  /* If it is (if X Y), look at Y.  */
		  if (EQ (carelt, Qif)
		      && EQ (Fnthcdr (make_number (3), elt), Qnil))
		    elt = Fnth (make_number (2), elt);
		  /* If it is (when ... Y), look at Y.  */
		  else if (EQ (carelt, Qwhen))
		    {
		      while (CONSP (XCDR (elt)))
			elt = XCDR (elt);
		      elt = Fcar (elt);
		    }

		  /* If the function call we're looking at
		     is a special preserved one, copy the
		     whole expression for this argument.  */
		  if (CONSP (elt))
		    {
		      presflag = Fmemq (Fcar (elt), preserved_fns);
		      if (!NILP (presflag))
			Fsetcar (valtail, Fcar (intail));
		    }
		}
	    }
	}
    }
}
Ejemplo n.º 15
0
Archivo: require.c Proyecto: 8l/xedit
LispObj *
Lisp_Require(LispBuiltin *builtin)
/*
 require module &optional pathname
 */
{
    char filename[1024], *ext;
    int len;

    LispObj *obj, *module, *pathname;

    pathname = ARGUMENT(1);
    module = ARGUMENT(0);

    CHECK_STRING(module);
    if (pathname != UNSPEC) {
	if (PATHNAMEP(pathname))
	    pathname = CAR(pathname->data.pathname);
	else {
	    CHECK_STRING(pathname);
	}
    }
    else
	pathname = module;

    for (obj = MOD; CONSP(obj); obj = CDR(obj)) {
	if (strcmp(THESTR(CAR(obj)), THESTR(module)) == 0)
	    return (module);
    }

    if (THESTR(pathname)[0] != '/') {
#ifdef LISPDIR
	snprintf(filename, sizeof(filename), "%s", LISPDIR);
#else
	getcwd(filename, sizeof(filename));
#endif
    }
    else
	filename[0] = '\0';
    *(filename + sizeof(filename) - 5) = '\0';	/* make sure there is place for ext */
    len = strlen(filename);
    if (!len || filename[len - 1] != '/') {
	strcat(filename, "/");
	++len;
    }

    snprintf(filename + len, sizeof(filename) - len - 5, "%s", THESTR(pathname));

    ext = filename + strlen(filename);

#ifdef SHARED_MODULES
    strcpy(ext, ".so");
    if (access(filename, R_OK) == 0) {
	LispModule *lisp_module;
	char data[64];
	int len;

	if (lisp__data.module == NULL) {
	    /* export our own symbols */
	    if (dlopen(NULL, RTLD_LAZY | RTLD_GLOBAL) == NULL)
		LispDestroy("%s: ", STRFUN(builtin), dlerror());
	}

	lisp_module = (LispModule*)LispMalloc(sizeof(LispModule));
	if ((lisp_module->handle =
	     dlopen(filename, RTLD_LAZY | RTLD_GLOBAL)) == NULL)
	    LispDestroy("%s: dlopen: %s", STRFUN(builtin), dlerror());
	snprintf(data, sizeof(data), "%sLispModuleData", THESTR(module));
	if ((lisp_module->data =
	     (LispModuleData*)dlsym(lisp_module->handle, data)) == NULL) {
	    dlclose(lisp_module->handle);
	    LispDestroy("%s: cannot find LispModuleData for %s",
			STRFUN(builtin), STROBJ(module));
	}
	LispMused(lisp_module);
	lisp_module->next = lisp__data.module;
	lisp__data.module = lisp_module;
	if (lisp_module->data->load)
	    (lisp_module->data->load)();

	if (MOD == NIL)
	    MOD = CONS(module, NIL);
	else {
	    RPLACD(MOD, CONS(CAR(MOD), CDR(MOD)));
	    RPLACA(MOD, module);
	}
	LispSetVar(lisp__data.modules, MOD);

	return (module);
    }
#endif

    strcpy(ext, ".lsp");
    (void)LispLoadFile(STRING(filename), 0, 0, 0);

    return (module);
}
Ejemplo n.º 16
0
static Lisp_Object
get_object_file_name (Lisp_Object filepos)
{
  REGISTER int fd;
  REGISTER Ibyte *name_nonreloc = 0;
  EMACS_INT position;
  Lisp_Object file, tem;
  Lisp_Object name_reloc = Qnil;
  int standard_doc_file = 0;

  if (FIXNUMP (filepos))
    {
      file = Vinternal_doc_file_name;
      standard_doc_file = 1;
      position = XFIXNUM (filepos);
    }
  else if (CONSP (filepos) && FIXNUMP (XCDR (filepos)))
    {
      file = XCAR (filepos);
      position = XFIXNUM (XCDR (filepos));
      if (position < 0)
	position = - position;
    }
  else
    return Qnil;

  if (!STRINGP (file))
    return Qnil;

  /* Put the file name in NAME as a C string.
     If it is relative, combine it with Vdoc_directory.  */

  tem = Ffile_name_absolute_p (file);
  if (NILP (tem))
    {
      Bytecount minsize;
      /* XEmacs: Move this check here.  OK if called during loadup to
	 load byte code instructions. */
      if (!STRINGP (Vdoc_directory))
	return Qnil;

      minsize = XSTRING_LENGTH (Vdoc_directory);
      /* sizeof ("../lib-src/") == 12 */
      if (minsize < 12)
	minsize = 12;
      name_nonreloc = alloca_ibytes (minsize + XSTRING_LENGTH (file) + 8);
      string_join (name_nonreloc, Vdoc_directory, file);
    }
  else
    name_reloc = file;

  fd = qxe_open (name_nonreloc ? name_nonreloc :
		 XSTRING_DATA (name_reloc), O_RDONLY | OPEN_BINARY, 0);
  if (fd < 0)
    {
      if (purify_flag)
	{
	    /* sizeof ("../lib-src/") == 12 */
	  name_nonreloc = alloca_ibytes (12 + XSTRING_LENGTH (file) + 8);
	  /* Preparing to dump; DOC file is probably not installed.
	     So check in ../lib-src. */
	  qxestrcpy_ascii (name_nonreloc, "../lib-src/");
	  qxestrcat (name_nonreloc, XSTRING_DATA (file));

	  fd = qxe_open (name_nonreloc, O_RDONLY | OPEN_BINARY, 0);
	}

      if (fd < 0)
	report_file_error ("Cannot open doc string file",
			   name_nonreloc ? build_istring (name_nonreloc) :
			   name_reloc);
    }

  tem = extract_object_file_name (fd, position, name_nonreloc, name_reloc,
			      standard_doc_file);
  retry_close (fd);

  if (!STRINGP (tem))
    signal_error_1 (Qinvalid_byte_code, tem);

  return tem;
}
Ejemplo n.º 17
0
lref_t debug_print_object(lref_t obj, lref_t port, bool machine_readable)
{
     _TCHAR buf[STACK_STRBUF_LEN];

     if (DEBUG_FLAG(DF_PRINT_ADDRESSES))
          scwritef("#@~c&=", port, obj);

     lref_t tmp;
     size_t ii;
     lref_t slots;
     const _TCHAR *fast_op_name;

     switch (TYPE(obj))
     {
     case TC_NIL:
          WRITE_TEXT_CONSTANT(port, _T("()"));
          break;

     case TC_BOOLEAN:
          if (TRUEP(obj))
               WRITE_TEXT_CONSTANT(port, _T("#t"));
          else
               WRITE_TEXT_CONSTANT(port, _T("#f"));
          break;

     case TC_CONS:
          write_char(port, _T('('));
          debug_print_object(lcar(obj), port, machine_readable);

          for (tmp = lcdr(obj); CONSP(tmp); tmp = lcdr(tmp))
          {
               write_char(port, _T(' '));
               debug_print_object(lcar(tmp), port, machine_readable);
          }

          if (!NULLP(tmp))
          {
               WRITE_TEXT_CONSTANT(port, _T(" . "));
               debug_print_object(tmp, port, machine_readable);
          }

          write_char(port, _T(')'));
          break;

     case TC_FIXNUM:
          _sntprintf(buf, STACK_STRBUF_LEN, _T("%" SCAN_PRIiFIXNUM), FIXNM(obj));
          write_text(port, buf, _tcslen(buf));
          break;

     case TC_FLONUM:
          debug_print_flonum(obj, port, machine_readable);
          break;

     case TC_CHARACTER:
          if (machine_readable)
          {
               if (CHARV(obj) < CHARNAMECOUNT)
                    scwritef(_T("#\\~cs"), port, charnames[(size_t) CHARV(obj)]);
               else if (CHARV(obj) >= CHAREXTENDED - 1)
                    scwritef(_T("#\\<~cd>"), port, (int) CHARV(obj));
               else
                    scwritef(_T("#\\~cc"), port, (int) CHARV(obj));
          }
          else
               scwritef(_T("~cc"), port, (int) CHARV(obj));
          break;

     case TC_SYMBOL:
          if (NULLP(SYMBOL_HOME(obj)))
          {
               if (DEBUG_FLAG(DF_PRINT_FOR_DIFF))
                    scwritef("#:<uninterned-symbol>", port);
               else
                    scwritef("#:~a@~c&", port, SYMBOL_PNAME(obj), obj);
          }
          else if (SYMBOL_HOME(obj) == interp.control_fields[VMCTRL_PACKAGE_KEYWORD])
               scwritef(":~a", port, SYMBOL_PNAME(obj));
          else
          {
               /* With only a minimal c-level package implementation, we
                * just assume every symbol is private. */
               scwritef("~a::~a", port, SYMBOL_HOME(obj)->as.package.name, SYMBOL_PNAME(obj));
          }
          break;

     case TC_VECTOR:
          WRITE_TEXT_CONSTANT(port, _T("["));

          for (ii = 0; ii < obj->as.vector.dim; ii++)
          {
               debug_print_object(obj->as.vector.data[ii], port, true);

               if (ii + 1 < obj->as.vector.dim)
                    write_char(port, _T(' '));
          }

          write_char(port, _T(']'));
          break;

     case TC_STRUCTURE:
          WRITE_TEXT_CONSTANT(port, _T("#S("));

          debug_print_object(CAR(STRUCTURE_LAYOUT(obj)), port, true);

          for (ii = 0, slots = CAR(CDR(STRUCTURE_LAYOUT(obj)));
               ii < STRUCTURE_DIM(obj); ii++, slots = CDR(slots))
          {
               WRITE_TEXT_CONSTANT(port, _T(" "));
               debug_print_object(CAR(CAR(slots)), port, true);
               WRITE_TEXT_CONSTANT(port, _T(" "));
               debug_print_object(STRUCTURE_ELEM(obj, ii), port, true);
          }

          WRITE_TEXT_CONSTANT(port, _T(")"));
          break;

     case TC_STRING:
          debug_print_string(obj, port, machine_readable);
          break;
     case TC_HASH:
          debug_print_hash(obj, port, machine_readable);
          break;

     case TC_PACKAGE:
          scwritef("~u ~a", port, (lref_t) obj, obj->as.package.name);
          break;

     case TC_SUBR:
          scwritef("~u,~cd:~a", port, (lref_t) obj, SUBR_TYPE(obj), SUBR_NAME(obj));
          break;

     case TC_CLOSURE:
          if (DEBUG_FLAG(DF_PRINT_CLOSURE_CODE))
               scwritef("~u\n\tcode:~s\n\tenv:~s\n\tp-list:~s", port,
                        (lref_t) obj, CLOSURE_CODE(obj), CLOSURE_ENV(obj),
                        CLOSURE_PROPERTY_LIST(obj));

          else
               scwritef("~u", port, (lref_t) obj);
          break;

     case TC_VALUES_TUPLE:
          scwritef("~u ~s", port, (lref_t) obj, obj->as.values_tuple.values);
          break;

     case TC_MACRO:
          if (DEBUG_FLAG(DF_PRINT_CLOSURE_CODE))
               scwritef("~u ~s", port, (lref_t) obj, obj->as.macro.transformer);
          else
               scwritef("~u", port, (lref_t) obj);
          break;

     case TC_END_OF_FILE:
          scwritef("~u", port, (lref_t) obj);
          break;

     case TC_PORT:
          scwritef(_T("~u~cs~cs~cs ~cs ~s"), port,
                   obj,
                   PORT_INPUTP(obj) ? " (input)" : "",
                   PORT_OUTPUTP(obj) ? " (output)" : "",
                   BINARY_PORTP(obj) ? " (binary)" : "",
                   PORT_CLASS(obj)->name,
                   PORT_PINFO(obj)->port_name);
          break;

     case TC_FAST_OP:
          fast_op_name = fast_op_opcode_name(obj->header.opcode);

          if (fast_op_name)
               scwritef("#<FOP@~c&:~cs ~s ~s => ~s>", port, (lref_t) obj,
                        fast_op_name,
                        obj->as.fast_op.arg1,
                        obj->as.fast_op.arg2,
                        obj->as.fast_op.next);
          else
               scwritef("#<FOP@~c&:~cd ~s ~s => ~s>", port, (lref_t) obj,
                        obj->header.opcode,
                        obj->as.fast_op.arg1,
                        obj->as.fast_op.arg2,
                        obj->as.fast_op.next);
     break;

     case TC_FASL_READER:
          scwritef(_T("~u~s"), port,
                   obj,
                   FASL_READER_PORT(obj));
          break;

     case TC_UNBOUND_MARKER:
          scwritef("#<UNBOUND-MARKER>", port);
          break;

     case TC_FREE_CELL:
          scwritef("#<FREE CELL -- Forget a call to gc_mark? ~c&>", port, obj);
          break;

     default:
          scwritef("#<INVALID OBJECT - UNKNOWN TYPE ~c&>", port, obj);
     }

     return port;
}
Ejemplo n.º 18
0
See inotify(7) and inotify_add_watch(2) for further information.  The
inotify fd is managed internally and there is no corresponding
inotify_init.  Use `inotify-rm-watch' to remove a watch.

Also note, that the following inotify bit-masks can not be used, due
to the fact that descriptors are shared across different callers.

IN_EXCL_UNLINK
IN_MASK_ADD
IN_ONESHOT
IN_ONLYDIR  */)
     (Lisp_Object filename, Lisp_Object aspect, Lisp_Object callback)
{
  Lisp_Object encoded_file_name;
  bool dont_follow = (CONSP (aspect)
		      ? ! NILP (Fmemq (Qdont_follow, aspect))
		      : EQ (Qdont_follow, aspect));
  int wd = -1;
  uint32_t mask = (INOTIFY_DEFAULT_MASK
                   | (dont_follow ? IN_DONT_FOLLOW : 0));

  CHECK_STRING (filename);

  if (inotifyfd < 0)
    {
      inotifyfd = inotify_init1 (IN_NONBLOCK | IN_CLOEXEC);
      if (inotifyfd < 0)
	report_file_notify_error ("File watching is not available", Qnil);
      watch_list = Qnil;
      add_read_fd (inotifyfd, &inotify_callback, NULL);
Ejemplo n.º 19
0
Archivo: w32menu.c Proyecto: 0xAX/emacs
static Lisp_Object
simple_dialog_show (struct frame *f, Lisp_Object contents, Lisp_Object header)
{
  int answer;
  UINT type;
  Lisp_Object lispy_answer = Qnil, temp = XCAR (contents);

  type = MB_YESNO;

  /* Since we only handle Yes/No dialogs, and we already checked
     is_simple_dialog, we don't need to worry about checking contents
     to see what type of dialog to use.  */

  /* Use Unicode if possible, so any language can be displayed.  */
  if (unicode_message_box)
    {
      WCHAR *text;
      const WCHAR *title;
      USE_SAFE_ALLOCA;

      if (STRINGP (temp))
	{
	  char *utf8_text = SSDATA (ENCODE_UTF_8 (temp));
	  /* Be pessimistic about the number of characters needed.
	     Remember characters outside the BMP will take more than
	     one utf16 word, so we cannot simply use the character
	     length of temp.  */
	  int utf8_len = strlen (utf8_text);
	  text = SAFE_ALLOCA ((utf8_len + 1) * sizeof (WCHAR));
	  utf8to16 ((unsigned char *)utf8_text, utf8_len, text);
	}
      else
	{
	  text = (WCHAR *)L"";
	}

      if (NILP (header))
	{
	  title = L"Question";
	  type |= MB_ICONQUESTION;
	}
      else
	{
	  title = L"Information";
	  type |= MB_ICONINFORMATION;
	}

      answer = unicode_message_box (FRAME_W32_WINDOW (f), text, title, type);
      SAFE_FREE ();
    }
  else
    {
      const char *text, *title;

      /* Fall back on ANSI message box, but at least use system
	 encoding so questions representable by the system codepage
	 are encoded properly.  */
      if (STRINGP (temp))
	text = SSDATA (ENCODE_SYSTEM (temp));
      else
	text = "";

      if (NILP (header))
	{
	  title = "Question";
	  type |= MB_ICONQUESTION;
	}
      else
	{
	  title = "Information";
	  type |= MB_ICONINFORMATION;
	}

      answer = MessageBox (FRAME_W32_WINDOW (f), text, title, type);
    }

  if (answer == IDYES)
    lispy_answer = build_string ("Yes");
  else if (answer == IDNO)
    lispy_answer = build_string ("No");
  else
    Fsignal (Qquit, Qnil);

  for (temp = XCDR (contents); CONSP (temp); temp = XCDR (temp))
    {
      Lisp_Object item, name, value;
      item = XCAR (temp);
      if (CONSP (item))
	{
	  name = XCAR (item);
	  value = XCDR (item);
	}
      else
	{
	  name = item;
	  value = Qnil;
	}

      if (!NILP (Fstring_equal (name, lispy_answer)))
	{
	  return value;
	}
    }
  Fsignal (Qquit, Qnil);
  return Qnil;
}
Ejemplo n.º 20
0
SCM_EXPORT ScmObj
scm_p_equalp(ScmObj obj1, ScmObj obj2)
{
    enum ScmObjType type;
    ScmObj elm1, elm2;
#if SCM_USE_VECTOR
    ScmObj *v1, *v2;
    scm_int_t i, len;
#endif
    DECLARE_FUNCTION("equal?", procedure_fixed_2);

    if (EQ(obj1, obj2))
        return SCM_TRUE;

    type = SCM_TYPE(obj1);

    /* different type */
    if (type != SCM_TYPE(obj2))
        return SCM_FALSE;

    /* same type */
    switch (type) {
#if (SCM_USE_INT && !SCM_HAS_IMMEDIATE_INT_ONLY)
    case ScmInt:
        return MAKE_BOOL(SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2));
#endif

#if (SCM_USE_CHAR && !SCM_HAS_IMMEDIATE_CHAR_ONLY)
    case ScmChar:
        return MAKE_BOOL(SCM_CHAR_VALUE(obj1) == SCM_CHAR_VALUE(obj2));
#endif

#if SCM_USE_STRING
    case ScmString:
        return MAKE_BOOL(STRING_EQUALP(obj1, obj2));
#endif

    case ScmCons:
        for (; CONSP(obj1) && CONSP(obj2); obj1 = CDR(obj1), obj2 = CDR(obj2))
        {
            elm1 = CAR(obj1);
            elm2 = CAR(obj2);
            if (!EQ(elm1, elm2)
                && (SCM_TYPE(elm1) != SCM_TYPE(elm2)
                    || !EQUALP(elm1, elm2)))
                return SCM_FALSE;
        }
        /* compare last cdr */
        return (EQ(obj1, obj2)) ? SCM_TRUE : scm_p_equalp(obj1, obj2);

#if SCM_USE_VECTOR
    case ScmVector:
        len = SCM_VECTOR_LEN(obj1);
        if (len != SCM_VECTOR_LEN(obj2))
            return SCM_FALSE;

        v1 = SCM_VECTOR_VEC(obj1);
        v2 = SCM_VECTOR_VEC(obj2);
        for (i = 0; i < len; i++) {
            elm1 = v1[i];
            elm2 = v2[i];
            if (!EQ(elm1, elm2)
                && (SCM_TYPE(elm1) != SCM_TYPE(elm2)
                    || !EQUALP(elm1, elm2)))
                return SCM_FALSE;
        }
        return SCM_TRUE;
#endif

#if SCM_USE_SSCM_EXTENSIONS
    case ScmCPointer:
        return MAKE_BOOL(SCM_C_POINTER_VALUE(obj1)
                         == SCM_C_POINTER_VALUE(obj2));

    case ScmCFuncPointer:
        return MAKE_BOOL(SCM_C_FUNCPOINTER_VALUE(obj1)
                         == SCM_C_FUNCPOINTER_VALUE(obj2));
#endif

    default:
        break;
    }

    return SCM_FALSE;
}
Ejemplo n.º 21
0
Archivo: xaw.c Proyecto: aosm/X11
LispObj *
Lisp_XawListChange(LispBuiltin *builtin)
/*
 xaw-list-change widget list &optional longest resize
 */
{
    Widget widget;
    String *list;
    int i, nitems;
    int longest;
    Boolean resize;
    LispObj *object;
    WidgetData *data;

    LispObj *owidget, *olist, *olongest, *oresize;

    oresize = ARGUMENT(3);
    olongest = ARGUMENT(2);
    olist = ARGUMENT(1);
    owidget = ARGUMENT(0);

    if (!CHECKO(owidget, xawWidget_t))
	LispDestroy("%s: cannot convert %s to Widget",
		    STRFUN(builtin), STROBJ(owidget));
    widget = (Widget)(owidget->data.opaque.data);

    CHECK_LIST(olist);
    for (nitems = 0, object = olist; CONSP(object);
	 ++nitems, object = CDR(object))
	CHECK_STRING(CAR(object));

    if (olongest != UNSPEC) {
	CHECK_INDEX(olongest);
	longest = FIXNUM_VALUE(olongest);
    }
    else
	XtVaGetValues(widget, XtNlongest, &longest, NULL, 0);
    resize = oresize != UNSPEC && oresize != NIL;

    /* No errors in arguments, build string list */
    list = (String*)XtMalloc(sizeof(String) * nitems);
    for (i = 0, object = olist; CONSP(object); i++, object = CDR(object))
	list[i] = THESTR(CAR(object));

    /* Check if xaw-list-change was already called
      * for this widget and free previous data */
    for (i = 0; i < num_list_data; i++)
	if ((Widget)CAR(list_data[i]->object)->data.opaque.data == widget) {
	    XtRemoveCallback(widget, XtNdestroyCallback,
			     LispXawCleanupCallback, list_data[i]);
	    LispXawCleanupCallback(widget, list_data[i], NULL);
	    break;
	}

    if (i >= num_list_data) {
	++num_list_data;
	list_data = (WidgetData**)XtRealloc((XtPointer)list_data,
					    sizeof(WidgetData*) * num_list_data);
    }

    data = (WidgetData*)XtMalloc(sizeof(WidgetData));
    data->data = list;
    list_data[i] = data;
    data->object = CONS(owidget, olist);
    PROTECT(owidget, data->object);
    XtAddCallback(widget, XtNdestroyCallback, LispXawCleanupCallback, data);

    XawListChange(widget, list, nitems, longest, resize);

    return (olist);
}
Ejemplo n.º 22
0
// FIXME can't cope with circular lists
CELL func_listp(CELL frame)
{
	CELL list = FV0;
	while(CONSP(list)) list = CDR(list);
	return MKBOOL(NULLP(list));
}
Ejemplo n.º 23
0
DEFUN ("handle-save-session", Fhandle_save_session,
       Shandle_save_session, 1, 1, "e",
       doc: /* Handle the save_yourself event from a session manager.
A session manager can tell Emacs that the window system is shutting down
by sending Emacs a save_yourself message.  Emacs executes this function when
such an event occurs.  This function then executes `emacs-session-save'.
After that, this function informs the session manager that it can continue
or abort shutting down the window system depending on the return value
from `emacs-session-save'  If the return value is non-nil the session manager
is told to abort the window system shutdown.

Do not call this function yourself. */)
  (Lisp_Object event)
{
  bool kill_emacs = (CONSP (event) && CONSP (XCDR (event))
		     && EQ (Qt, XCAR (XCDR (event))));

  /* Check doing_interact so that we don't do anything if someone called
     this at the wrong time. */
  if (doing_interact && ! kill_emacs)
    {
      bool cancel_shutdown = ! NILP (call0 (intern ("emacs-session-save")));

      SmcInteractDone (smc_conn, cancel_shutdown);
      SmcSaveYourselfDone (smc_conn, True);

      doing_interact = false;
    }
  else if (kill_emacs)
    {
Ejemplo n.º 24
0
CELL func_pairp(CELL frame)
{
	return MKBOOL(CONSP(FV0));
}
Ejemplo n.º 25
0
class_t *new_ooclass(at *classname, at *atsuper, at *new_slots, at *defaults)
{
   ifn (SYMBOLP(classname))
      error(NIL, "not a valid class name", classname);
   ifn (length(new_slots) == length(defaults))
      error(NIL, "number of slots must match number of defaults", NIL);
   ifn (CLASSP(atsuper))
      error(NIL, "not a class", atsuper);

   class_t *super = Mptr(atsuper);
   if (builtin_class_p(super))
      error(NIL, "superclass not descendend of class <object>", atsuper);

   at *p = new_slots;
   at *q = defaults;
   int n = 0;
   while (CONSP(p) && CONSP(q)) {
      ifn (SYMBOLP(Car(p)))
         error(NIL, "not a symbol", Car(p));
      for (int i=0; i<super->num_slots; i++)
         if (Car(p) == super->slots[i])
            error(NIL, "a superclass has slot of this name", Car(p));
      p = Cdr(p);
      q = Cdr(q);
      n++;
   }
   assert(!p && !q);
  
   /* builds the new class */
   class_t *cl = mm_alloc(mt_class);
   *cl = *object_class;
   if (new_slots) {
      int num_slots = n + super->num_slots;
      cl->slots = mm_allocv(mt_refs, num_slots*sizeof(at *));
      cl->defaults = mm_allocv(mt_refs, num_slots*sizeof(at *));
      int i = 0;
      for (; i<super->num_slots; i++) {
         cl->slots[i] = super->slots[i];
         cl->defaults[i] = super->defaults[i];
      }
      for (at *s = new_slots, *d = defaults; CONSP(s); i++, s = Cdr(s), d = Cdr(d)) {
         cl->slots[i] = Car(s);
         cl->defaults[i] = Car(d);
      }
      assert(i == num_slots);
      cl->num_slots = num_slots;
   } else {
      cl->slots = super->slots;
      cl->defaults = super->defaults;
      cl->num_slots = super->num_slots;
   }

   /* Sets up classname */
   cl->classname = classname;
   cl->priminame = classname;
   
   /* Sets up lists */
   cl->super = super;
   cl->atsuper = atsuper;
   cl->nextclass = super->subclasses;
   cl->subclasses = 0L;
   super->subclasses = cl;
  
   /* Initialize the slots */
   cl->myslots = new_slots;
   cl->mydefaults = defaults;
   
   /* Initialize the methods and hash table */
   cl->methods = NIL;
   cl->hashtable = 0L;
   cl->hashsize = 0;
   cl->hashok = 0;
   
   /* Initialize DHCLASS stuff */
   cl->has_compiled_part = super->has_compiled_part;
   cl->num_cslots = super->num_cslots;
   cl->classdoc = 0;
   cl->kname = 0;
   
   /* Create AT and returns it */
   assert(class_class);
   cl->backptr = new_at(class_class, cl);
   return cl;
}
Ejemplo n.º 26
0
static Lisp_Object
xftfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
{
  FcResult result;
  Display *display = FRAME_X_DISPLAY (f);
  Lisp_Object val, filename, idx, font_object;
  FcPattern *pat = NULL, *match;
  struct xftfont_info *xftfont_info = NULL;
  struct font *font;
  double size = 0;
  XftFont *xftfont = NULL;
  int spacing;
  char name[256];
  int len, i;
  XGlyphInfo extents;
  FT_Face ft_face;
  FcMatrix *matrix;

  val = assq_no_quit (QCfont_entity, AREF (entity, FONT_EXTRA_INDEX));
  if (! CONSP (val))
    return Qnil;
  val = XCDR (val);
  filename = XCAR (val);
  idx = XCDR (val);
  size = XINT (AREF (entity, FONT_SIZE_INDEX));
  if (size == 0)
    size = pixel_size;
  pat = FcPatternCreate ();
  FcPatternAddInteger (pat, FC_WEIGHT, FONT_WEIGHT_NUMERIC (entity));
  i = FONT_SLANT_NUMERIC (entity) - 100;
  if (i < 0) i = 0;
  FcPatternAddInteger (pat, FC_SLANT, i);
  FcPatternAddInteger (pat, FC_WIDTH, FONT_WIDTH_NUMERIC (entity));
  FcPatternAddDouble (pat, FC_PIXEL_SIZE, pixel_size);
  val = AREF (entity, FONT_FAMILY_INDEX);
  if (! NILP (val))
    FcPatternAddString (pat, FC_FAMILY, (FcChar8 *) SDATA (SYMBOL_NAME (val)));
  val = AREF (entity, FONT_FOUNDRY_INDEX);
  if (! NILP (val))
    FcPatternAddString (pat, FC_FOUNDRY, (FcChar8 *) SDATA (SYMBOL_NAME (val)));
  val = AREF (entity, FONT_SPACING_INDEX);
  if (! NILP (val))
    FcPatternAddInteger (pat, FC_SPACING, XINT (val));
  val = AREF (entity, FONT_DPI_INDEX);
  if (! NILP (val))
    {
      double dbl = XINT (val);

      FcPatternAddDouble (pat, FC_DPI, dbl);
    }
  val = AREF (entity, FONT_AVGWIDTH_INDEX);
  if (INTEGERP (val) && XINT (val) == 0)
    FcPatternAddBool (pat, FC_SCALABLE, FcTrue);
  /* This is necessary to identify the exact font (e.g. 10x20.pcf.gz
     over 10x20-ISO8859-1.pcf.gz).  */
  FcPatternAddCharSet (pat, FC_CHARSET, ftfont_get_fc_charset (entity));

  xftfont_add_rendering_parameters (pat, entity);

  FcPatternAddString (pat, FC_FILE, (FcChar8 *) SDATA (filename));
  FcPatternAddInteger (pat, FC_INDEX, XINT (idx));


  block_input ();
  /* Make sure that the Xrender extension is added before the Xft one.
     Otherwise, the close-display hook set by Xft is called after the
     one for Xrender, and the former tries to re-add the latter.  This
     results in inconsistency of internal states and leads to X
     protocol error when one reconnects to the same X server.
     (Bug#1696)  */
  {
    int event_base, error_base;
    XRenderQueryExtension (display, &event_base, &error_base);
  }

  /* Substitute in values from X resources and XftDefaultSet.  */
  XftDefaultSubstitute (display, FRAME_X_SCREEN_NUMBER (f), pat);
  match = XftFontMatch (display, FRAME_X_SCREEN_NUMBER (f), pat, &result);
  xftfont_fix_match (pat, match);

  FcPatternDestroy (pat);
  xftfont = XftFontOpenPattern (display, match);
  if (!xftfont)
    {
      unblock_input ();
      XftPatternDestroy (match);
      return Qnil;
    }
  ft_face = XftLockFace (xftfont);
  unblock_input ();

  /* We should not destroy PAT here because it is kept in XFTFONT and
     destroyed automatically when XFTFONT is closed.  */
  font_object = font_make_object (VECSIZE (struct xftfont_info), entity, size);
  ASET (font_object, FONT_TYPE_INDEX, Qxft);
  len = font_unparse_xlfd (entity, size, name, 256);
  if (len > 0)
    ASET (font_object, FONT_NAME_INDEX, make_string (name, len));
  len = font_unparse_fcname (entity, size, name, 256);
  if (len > 0)
    ASET (font_object, FONT_FULLNAME_INDEX, make_string (name, len));
  else
    ASET (font_object, FONT_FULLNAME_INDEX,
	  AREF (font_object, FONT_NAME_INDEX));
  ASET (font_object, FONT_FILE_INDEX, filename);
  ASET (font_object, FONT_FORMAT_INDEX,
	ftfont_font_format (xftfont->pattern, filename));
  font = XFONT_OBJECT (font_object);
  font->pixel_size = size;
  font->driver = &xftfont_driver;
  font->encoding_charset = font->repertory_charset = -1;

  xftfont_info = (struct xftfont_info *) font;
  xftfont_info->display = display;
  xftfont_info->xftfont = xftfont;
  /* This means that there's no need of transformation.  */
  xftfont_info->matrix.xx = 0;
  if (FcPatternGetMatrix (xftfont->pattern, FC_MATRIX, 0, &matrix)
      == FcResultMatch)
    {
      xftfont_info->matrix.xx = 0x10000L * matrix->xx;
      xftfont_info->matrix.yy = 0x10000L * matrix->yy;
      xftfont_info->matrix.xy = 0x10000L * matrix->xy;
      xftfont_info->matrix.yx = 0x10000L * matrix->yx;
    }
  if (INTEGERP (AREF (entity, FONT_SPACING_INDEX)))
    spacing = XINT (AREF (entity, FONT_SPACING_INDEX));
  else
    spacing = FC_PROPORTIONAL;
  if (! ascii_printable[0])
    {
      int ch;
      for (ch = 0; ch < 95; ch++)
	ascii_printable[ch] = ' ' + ch;
    }
  block_input ();

  /* Unfortunately Xft doesn't provide a way to get minimum char
     width.  So, we set min_width to space_width.  */

  if (spacing != FC_PROPORTIONAL
#ifdef FC_DUAL
      && spacing != FC_DUAL
#endif	/* FC_DUAL */
      )
    {
      font->min_width = font->max_width = font->average_width
	= font->space_width = xftfont->max_advance_width;
      XftTextExtents8 (display, xftfont, ascii_printable + 1, 94, &extents);
    }
  else
    {
      XftTextExtents8 (display, xftfont, ascii_printable, 1, &extents);
      font->min_width = font->max_width = font->space_width
	= extents.xOff;
      if (font->space_width <= 0)
	/* dirty workaround */
	font->space_width = pixel_size;
      XftTextExtents8 (display, xftfont, ascii_printable + 1, 94, &extents);
      font->average_width = (font->space_width + extents.xOff) / 95;
    }
  unblock_input ();

  font->ascent = xftfont->ascent;
  font->descent = xftfont->descent;
  if (pixel_size >= 5)
    {
      /* The above condition is a dirty workaround because
	 XftTextExtents8 behaves strangely for some fonts
	 (e.g. "Dejavu Sans Mono") when pixel_size is less than 5. */
      if (font->ascent < extents.y)
	font->ascent = extents.y;
      if (font->descent < extents.height - extents.y)
	font->descent = extents.height - extents.y;
    }
  font->height = font->ascent + font->descent;

  if (XINT (AREF (entity, FONT_SIZE_INDEX)) == 0)
    {
      int upEM = ft_face->units_per_EM;

      font->underline_position = -ft_face->underline_position * size / upEM;
      font->underline_thickness = ft_face->underline_thickness * size / upEM;
      if (font->underline_thickness > 2)
	font->underline_position -= font->underline_thickness / 2;
    }
  else
    {
      font->underline_position = -1;
      font->underline_thickness = 0;
    }
#ifdef HAVE_LIBOTF
  xftfont_info->maybe_otf = (ft_face->face_flags & FT_FACE_FLAG_SFNT) != 0;
  xftfont_info->otf = NULL;
#endif	/* HAVE_LIBOTF */
  xftfont_info->ft_size = ft_face->size;

  font->baseline_offset = 0;
  font->relative_compose = 0;
  font->default_ascent = 0;
  font->vertical_centering = 0;
#ifdef FT_BDF_H
  if (! (ft_face->face_flags & FT_FACE_FLAG_SFNT))
    {
      BDF_PropertyRec rec;

      if (FT_Get_BDF_Property (ft_face, "_MULE_BASELINE_OFFSET", &rec) == 0
	  && rec.type == BDF_PROPERTY_TYPE_INTEGER)
	font->baseline_offset = rec.u.integer;
      if (FT_Get_BDF_Property (ft_face, "_MULE_RELATIVE_COMPOSE", &rec) == 0
	  && rec.type == BDF_PROPERTY_TYPE_INTEGER)
	font->relative_compose = rec.u.integer;
      if (FT_Get_BDF_Property (ft_face, "_MULE_DEFAULT_ASCENT", &rec) == 0
	  && rec.type == BDF_PROPERTY_TYPE_INTEGER)
	font->default_ascent = rec.u.integer;
    }
#endif

  return font_object;
}
Ejemplo n.º 27
0
static int
get_logical_fringe_bitmap (struct window *w, Lisp_Object bitmap, int right_p, int partial_p)
{
  Lisp_Object cmap, bm1 = Qnil, bm2 = Qnil, bm;
  int ln1 = 0, ln2 = 0;
  int ix1 = right_p;
  int ix2 = ix1 + (partial_p ? 2 : 0);

  /* Lookup in buffer-local fringe-indicator-alist before global alist.

     Elements are:
	BITMAP		-- use for all
	(L R)		-- use for left right (whether partial or not)
	(L R PL PR)	-- use for left right partial-left partial-right
	If any value in local binding is not present or t, use global value.

     If partial, lookup partial bitmap in default value if not found here.
     If not partial, or no partial spec is present, use non-partial bitmap.  */

  if ((cmap = BVAR (XBUFFER (w->buffer), fringe_indicator_alist)), !NILP (cmap))
    {
      bm1 = Fassq (bitmap, cmap);
      if (CONSP (bm1))
	{
	  if ((bm1 = XCDR (bm1)), NILP (bm1))
	    return NO_FRINGE_BITMAP;
	  if (CONSP (bm1))
	    {
	      ln1 = XINT (Flength (bm1));
	      if (partial_p)
		{
		  if (ln1 > ix2)
		    {
		      bm = Fnth (make_number (ix2), bm1);
		      if (!EQ (bm, Qt))
			goto found;
		    }
		}
	      else
		{
		  if (ln1 > ix1)
		    {
		      bm = Fnth (make_number (ix1), bm1);
		      if (!EQ (bm, Qt))
			goto found;
		    }
		}
	    }
	  else if ((bm = bm1, !EQ (bm, Qt)))
	    goto found;
	}
    }

  if (!EQ (cmap, BVAR (&buffer_defaults, fringe_indicator_alist))
      && !NILP (BVAR (&buffer_defaults, fringe_indicator_alist)))
    {
      bm2 = Fassq (bitmap, BVAR (&buffer_defaults, fringe_indicator_alist));
      if (CONSP (bm2))
	{
	  if ((bm2 = XCDR (bm2)), !NILP (bm2))
	    {
	      if (CONSP (bm2))
		{
		  ln2 = XINT (Flength (bm2));
		  if (partial_p)
		    {
		      if (ln2 > ix2)
			{
			  bm = Fnth (make_number (ix2), bm2);
			  if (!EQ (bm, Qt))
			    goto found;
			}
		    }
		}
	    }
	}
    }

  if (ln1 > ix1)
    {
      bm = Fnth (make_number (ix1), bm1);
      if (!EQ (bm, Qt))
	goto found;
    }

  if (ln2 > ix1)
    {
      bm = Fnth (make_number (ix1), bm2);
      if (!EQ (bm, Qt))
	goto found;
      return NO_FRINGE_BITMAP;
    }
  else if ((bm = bm2, NILP (bm)))
    return NO_FRINGE_BITMAP;

 found:
  return lookup_fringe_bitmap (bm);
}
Ejemplo n.º 28
0
Archivo: doc.c Proyecto: T-force/emacs
Lisp_Object
get_doc_string (Lisp_Object filepos, int unibyte, int definition)
{
  char *from, *to;
  register int fd;
  register char *name;
  register char *p, *p1;
  EMACS_INT minsize;
  EMACS_INT offset, position;
  Lisp_Object file, tem;

  if (INTEGERP (filepos))
    {
      file = Vdoc_file_name;
      position = XINT (filepos);
    }
  else if (CONSP (filepos))
    {
      file = XCAR (filepos);
      position = XINT (XCDR (filepos));
    }
  else
    return Qnil;

  if (position < 0)
    position = - position;

  if (!STRINGP (Vdoc_directory))
    return Qnil;

  if (!STRINGP (file))
    return Qnil;

  /* Put the file name in NAME as a C string.
     If it is relative, combine it with Vdoc_directory.  */

  tem = Ffile_name_absolute_p (file);
  if (NILP (tem))
    {
      minsize = SCHARS (Vdoc_directory);
      /* sizeof ("../etc/") == 8 */
      if (minsize < 8)
	minsize = 8;
      name = (char *) alloca (minsize + SCHARS (file) + 8);
      strcpy (name, SSDATA (Vdoc_directory));
      strcat (name, SSDATA (file));
    }
  else
    {
      name = SSDATA (file);
    }

  fd = emacs_open (name, O_RDONLY, 0);
  if (fd < 0)
    {
#ifndef CANNOT_DUMP
      if (!NILP (Vpurify_flag))
	{
	  /* Preparing to dump; DOC file is probably not installed.
	     So check in ../etc. */
	  strcpy (name, "../etc/");
	  strcat (name, SSDATA (file));

	  fd = emacs_open (name, O_RDONLY, 0);
	}
#endif
      if (fd < 0)
	error ("Cannot open doc string file \"%s\"", name);
    }

  /* Seek only to beginning of disk block.  */
  /* Make sure we read at least 1024 bytes before `position'
     so we can check the leading text for consistency.  */
  offset = min (position, max (1024, position % (8 * 1024)));
  if (0 > lseek (fd, position - offset, 0))
    {
      emacs_close (fd);
      error ("Position %"pI"d out of range in doc string file \"%s\"",
	     position, name);
    }

  /* Read the doc string into get_doc_string_buffer.
     P points beyond the data just read.  */

  p = get_doc_string_buffer;
  while (1)
    {
      EMACS_INT space_left = (get_doc_string_buffer_size
			      - (p - get_doc_string_buffer));
      int nread;

      /* Allocate or grow the buffer if we need to.  */
      if (space_left == 0)
	{
	  EMACS_INT in_buffer = p - get_doc_string_buffer;
	  get_doc_string_buffer_size += 16 * 1024;
	  get_doc_string_buffer
	    = (char *) xrealloc (get_doc_string_buffer,
				 get_doc_string_buffer_size + 1);
	  p = get_doc_string_buffer + in_buffer;
	  space_left = (get_doc_string_buffer_size
			- (p - get_doc_string_buffer));
	}

      /* Read a disk block at a time.
         If we read the same block last time, maybe skip this?  */
      if (space_left > 1024 * 8)
	space_left = 1024 * 8;
      nread = emacs_read (fd, p, space_left);
      if (nread < 0)
	{
	  emacs_close (fd);
	  error ("Read error on documentation file");
	}
      p[nread] = 0;
      if (!nread)
	break;
      if (p == get_doc_string_buffer)
	p1 = strchr (p + offset, '\037');
      else
	p1 = strchr (p, '\037');
      if (p1)
	{
	  *p1 = 0;
	  p = p1;
	  break;
	}
      p += nread;
    }
  emacs_close (fd);

  /* Sanity checking.  */
  if (CONSP (filepos))
    {
      int test = 1;
      if (get_doc_string_buffer[offset - test++] != ' ')
	return Qnil;
      while (get_doc_string_buffer[offset - test] >= '0'
	     && get_doc_string_buffer[offset - test] <= '9')
	test++;
      if (get_doc_string_buffer[offset - test++] != '@'
	  || get_doc_string_buffer[offset - test] != '#')
	return Qnil;
    }
  else
    {
      int test = 1;
      if (get_doc_string_buffer[offset - test++] != '\n')
	return Qnil;
      while (get_doc_string_buffer[offset - test] > ' ')
	test++;
      if (get_doc_string_buffer[offset - test] != '\037')
	return Qnil;
    }

  /* Scan the text and perform quoting with ^A (char code 1).
     ^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_.  */
  from = get_doc_string_buffer + offset;
  to = get_doc_string_buffer + offset;
  while (from != p)
    {
      if (*from == 1)
	{
	  int c;

	  from++;
	  c = *from++;
	  if (c == 1)
	    *to++ = c;
	  else if (c == '0')
	    *to++ = 0;
	  else if (c == '_')
	    *to++ = 037;
	  else
	    {
	      unsigned char uc = c;
	      error ("\
Invalid data in documentation file -- %c followed by code %03o",
		     1, uc);
	    }
	}
      else
	*to++ = *from++;
    }

  /* If DEFINITION, read from this buffer
     the same way we would read bytes from a file.  */
  if (definition)
    {
      read_bytecode_pointer = (unsigned char *) get_doc_string_buffer + offset;
      return Fread (Qlambda);
    }

  if (unibyte)
    return make_unibyte_string (get_doc_string_buffer + offset,
				to - (get_doc_string_buffer + offset));
  else
    {
      /* The data determines whether the string is multibyte.  */
      EMACS_INT nchars =
	multibyte_chars_in_text (((unsigned char *) get_doc_string_buffer
				  + offset),
				 to - (get_doc_string_buffer + offset));
      return make_string_from_bytes (get_doc_string_buffer + offset,
				     nchars,
				     to - (get_doc_string_buffer + offset));
    }
}
Ejemplo n.º 29
0
/***************************************************************
 Vector
 ***************************************************************/
static void _vec_add_imp(vec_ptr vec, obj_ptr args, obj_ptr env)
{
    for (; CONSP(args); args = CDR(args))
        vec_add(vec, CAR(args));
 }
Ejemplo n.º 30
0
DEFUN ("handle-save-session", Fhandle_save_session,
       Shandle_save_session, 1, 1, "e",
       doc: /* Handle the save_yourself event from a session manager.
A session manager can tell Emacs that the window system is shutting down
by sending Emacs a save_yourself message.  Emacs executes this function when
such an event occurs.  This function then executes `emacs-session-save'.
After that, this function informs the session manager that it can continue
or abort shutting down the window system depending on the return value
from `emacs-session-save'  If the return value is non-nil the session manager
is told to abort the window system shutdown.

Do not call this function yourself. */)
  (Lisp_Object event)
{
  int kill_emacs = CONSP (event) && CONSP (XCDR (event))
    && EQ (Qt, XCAR (XCDR (event)));

  /* Check doing_interact so that we don't do anything if someone called
     this at the wrong time. */
  if (doing_interact && ! kill_emacs)
    {
      Bool cancel_shutdown = False;

      cancel_shutdown = ! EQ (call0 (intern ("emacs-session-save")), Qnil);

      SmcInteractDone (smc_conn, cancel_shutdown);
      SmcSaveYourselfDone (smc_conn, True);

      doing_interact = False;
    }