Ejemplo n.º 1
0
void Fset_cdddar(CL_FORM *base)
{
	Fcar(ARG(1));
	Fcdr(ARG(1));
	Fcdr(ARG(1));
	Fset_cdr(ARG(0));
}
Ejemplo n.º 2
0
void Fcddadr(CL_FORM *base)
{
	Fcdr(ARG(0));
	Fcar(ARG(0));
	Fcdr(ARG(0));
	Fcdr(ARG(0));
}
Ejemplo n.º 3
0
static void
store_function_docstring (Lisp_Object obj, ptrdiff_t offset)
{
  /* Don't use indirect_function here, or defaliases will apply their
     docstrings to the base functions (Bug#2603).  */
  Lisp_Object fun = SYMBOLP (obj) ? XSYMBOL (obj)->function : obj;

  /* The type determines where the docstring is stored.  */

  /* Lisp_Subrs have a slot for it.  */
  if (SUBRP (fun))
    {
      intptr_t negative_offset = - offset;
      XSUBR (fun)->doc = (char *) negative_offset;
    }

  /* If it's a lisp form, stick it in the form.  */
  else if (CONSP (fun))
    {
      Lisp_Object tem;

      tem = XCAR (fun);
      if (EQ (tem, Qlambda) || EQ (tem, Qautoload)
	  || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
	{
	  tem = Fcdr (Fcdr (fun));
	  if (CONSP (tem) && INTEGERP (XCAR (tem)))
	    /* FIXME: This modifies typically pure hash-cons'd data, so its
	       correctness is quite delicate.  */
	    XSETCAR (tem, make_number (offset));
	}
      else if (EQ (tem, Qmacro))
	store_function_docstring (XCDR (fun), offset);
    }

  /* Bytecode objects sometimes have slots for it.  */
  else if (COMPILEDP (fun))
    {
      /* This bytecode object must have a slot for the
	 docstring, since we've found a docstring for it.  */
      if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_DOC_STRING)
	ASET (fun, COMPILED_DOC_STRING, make_number (offset));
      else
	{
	  AUTO_STRING (format, "No docstring slot for %s");
	  CALLN (Fmessage, format,
		 (SYMBOLP (obj)
		  ? SYMBOL_NAME (obj)
		  : build_string ("<anonymous>")));
	}
    }
}
Ejemplo n.º 4
0
static Lisp_Object
call_process_cleanup (Lisp_Object arg)
{
  Lisp_Object fdpid = Fcdr (arg);
  int fd;
#if defined (MSDOS)
  Lisp_Object file;
#else
  pid_t pid;
#endif

  Fset_buffer (Fcar (arg));
  CONS_TO_INTEGER (Fcar (fdpid), int, fd);

#if defined (MSDOS)
  /* for MSDOS fdpid is really (fd . tempfile)  */
  file = Fcdr (fdpid);
  /* FD is -1 and FILE is "" when we didn't actually create a
     temporary file in call-process.  */
  if (fd >= 0)
    emacs_close (fd);
  if (!(strcmp (SDATA (file), NULL_DEVICE) == 0 || SREF (file, 0) == '\0'))
    unlink (SDATA (file));
#else /* not MSDOS */
  CONS_TO_INTEGER (Fcdr (fdpid), pid_t, pid);

  if (call_process_exited)
    {
      emacs_close (fd);
      return Qnil;
    }

  if (EMACS_KILLPG (pid, SIGINT) == 0)
    {
      ptrdiff_t count = SPECPDL_INDEX ();
      record_unwind_protect (call_process_kill, fdpid);
      message1 ("Waiting for process to die...(type C-g again to kill it instantly)");
      immediate_quit = 1;
      QUIT;
      wait_for_termination (pid);
      immediate_quit = 0;
      specpdl_ptr = specpdl + count; /* Discard the unwind protect.  */
      message1 ("Waiting for process to die...done");
    }
  synch_process_alive = 0;
  emacs_close (fd);
#endif /* not MSDOS */
  return Qnil;
}
Ejemplo n.º 5
0
static Lisp_Object
x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type,
		       int local_request, struct mac_display_info *dpyinfo)
{
  Lisp_Object local_value;
  Lisp_Object handler_fn, value, type, check;

  if (!x_selection_owner_p (selection_symbol, dpyinfo))
    return Qnil;

  local_value = LOCAL_SELECTION (selection_symbol, dpyinfo);

  /* TIMESTAMP is a special case.  */
  if (EQ (target_type, QTIMESTAMP))
    {
      handler_fn = Qnil;
      value = XCAR (XCDR (XCDR (local_value)));
    }
  else
    {
      /* Don't allow a quit within the converter.
	 When the user types C-g, he would be surprised
	 if by luck it came during a converter.  */
      ptrdiff_t count = SPECPDL_INDEX ();
      specbind (Qinhibit_quit, Qt);

      CHECK_SYMBOL (target_type);
      handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
      /* gcpro is not needed here since nothing but HANDLER_FN
	 is live, and that ought to be a symbol.  */

      if (!NILP (handler_fn))
	value = call3 (handler_fn,
		       selection_symbol, (local_request ? Qnil : target_type),
		       XCAR (XCDR (local_value)));
      else
	value = Qnil;
      unbind_to (count, Qnil);
    }

  if (local_request)
    return value;

  /* Make sure this value is of a type that we could transmit
     to another application.  */

  type = target_type;
  check = value;
  if (CONSP (value)
      && SYMBOLP (XCAR (value)))
    type = XCAR (value),
    check = XCDR (value);

  if (NILP (value) || mac_valid_selection_value_p (check, type))
    return value;

  signal_error ("Invalid data returned by selection-conversion function",
		list2 (handler_fn, value));
}
Ejemplo n.º 6
0
static Lisp_Object
call_process_kill (Lisp_Object fdpid)
{
  emacs_close (XFASTINT (Fcar (fdpid)));
  EMACS_KILLPG (XFASTINT (Fcdr (fdpid)), SIGKILL);
  synch_process_alive = 0;
  return Qnil;
}
Ejemplo n.º 7
0
static Lisp_Object
call_process_cleanup (Lisp_Object arg)
{
  Lisp_Object fdpid = Fcdr (arg);
#if defined (MSDOS)
  Lisp_Object file;
#else
  int pid;
#endif

  Fset_buffer (Fcar (arg));

#if defined (MSDOS)
  /* for MSDOS fdpid is really (fd . tempfile)  */
  file = Fcdr (fdpid);
  emacs_close (XFASTINT (Fcar (fdpid)));
  if (strcmp (SDATA (file), NULL_DEVICE) != 0)
    unlink (SDATA (file));
#else /* not MSDOS */
  pid = XFASTINT (Fcdr (fdpid));

  if (call_process_exited)
    {
      emacs_close (XFASTINT (Fcar (fdpid)));
      return Qnil;
    }

  if (EMACS_KILLPG (pid, SIGINT) == 0)
    {
      int count = SPECPDL_INDEX ();
      record_unwind_protect (call_process_kill, fdpid);
      message1 ("Waiting for process to die...(type C-g again to kill it instantly)");
      immediate_quit = 1;
      QUIT;
      wait_for_termination (pid);
      immediate_quit = 0;
      specpdl_ptr = specpdl + count; /* Discard the unwind protect.  */
      message1 ("Waiting for process to die...done");
    }
  synch_process_alive = 0;
  emacs_close (XFASTINT (Fcar (fdpid)));
#endif /* not MSDOS */
  return Qnil;
}
Ejemplo n.º 8
0
Archivo: doc.c Proyecto: rradonic/emacs
static void
store_function_docstring (Lisp_Object obj, EMACS_INT offset)
/* Use EMACS_INT because we get offset from pointer subtraction.  */
{
    /* Don't use indirect_function here, or defaliases will apply their
       docstrings to the base functions (Bug#2603).  */
    Lisp_Object fun = SYMBOLP (obj) ? XSYMBOL (obj)->function : obj;

    /* The type determines where the docstring is stored.  */

    /* Lisp_Subrs have a slot for it.  */
    if (SUBRP (fun))
    {
        intptr_t negative_offset = - offset;
        XSUBR (fun)->doc = (char *) negative_offset;
    }

    /* If it's a lisp form, stick it in the form.  */
    else if (CONSP (fun))
    {
        Lisp_Object tem;

        tem = XCAR (fun);
        if (EQ (tem, Qlambda) || EQ (tem, Qautoload)
                || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
        {
            tem = Fcdr (Fcdr (fun));
            if (CONSP (tem) && INTEGERP (XCAR (tem)))
                XSETCAR (tem, make_number (offset));
        }
        else if (EQ (tem, Qmacro))
            store_function_docstring (XCDR (fun), offset);
    }

    /* Bytecode objects sometimes have slots for it.  */
    else if (COMPILEDP (fun))
    {
        /* This bytecode object must have a slot for the
        docstring, since we've found a docstring for it.  */
        if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_DOC_STRING)
            ASET (fun, COMPILED_DOC_STRING, make_number (offset));
    }
}
Ejemplo n.º 9
0
static Lisp_Object
call_process_kill (Lisp_Object fdpid)
{
  int fd;
  pid_t pid;
  CONS_TO_INTEGER (Fcar (fdpid), int, fd);
  CONS_TO_INTEGER (Fcdr (fdpid), pid_t, pid);
  emacs_close (fd);
  EMACS_KILLPG (pid, SIGKILL);
  synch_process_alive = 0;
  return Qnil;
}
Ejemplo n.º 10
0
Archivo: menu.c Proyecto: ueno/emacs
/* Set up data in menu_items for a menu bar item
   whose event type is ITEM_KEY (with string ITEM_NAME)
   and whose contents come from the list of keymaps MAPS.  */
bool
parse_single_submenu (Lisp_Object item_key, Lisp_Object item_name,
		      Lisp_Object maps)
{
  Lisp_Object length;
  EMACS_INT len;
  Lisp_Object *mapvec;
  ptrdiff_t i;
  bool top_level_items = 0;
  USE_SAFE_ALLOCA;

  length = Flength (maps);
  len = XINT (length);

  /* Convert the list MAPS into a vector MAPVEC.  */
  SAFE_ALLOCA_LISP (mapvec, len);
  for (i = 0; i < len; i++)
    {
      mapvec[i] = Fcar (maps);
      maps = Fcdr (maps);
    }

  /* Loop over the given keymaps, making a pane for each map.
     But don't make a pane that is empty--ignore that map instead.  */
  for (i = 0; i < len; i++)
    {
      if (!KEYMAPP (mapvec[i]))
	{
	  /* Here we have a command at top level in the menu bar
	     as opposed to a submenu.  */
	  top_level_items = 1;
	  push_menu_pane (Qnil, Qnil);
	  push_menu_item (item_name, Qt, item_key, mapvec[i],
			  Qnil, Qnil, Qnil, Qnil);
	}
      else
	{
	  Lisp_Object prompt;
	  prompt = Fkeymap_prompt (mapvec[i]);
	  single_keymap_panes (mapvec[i],
			       !NILP (prompt) ? prompt : item_name,
			       item_key, 10);
	}
    }

  SAFE_FREE ();
  return top_level_items;
}
Ejemplo n.º 11
0
Archivo: menu.c Proyecto: stanis/emacs
/* Set up data in menu_items for a menu bar item
   whose event type is ITEM_KEY (with string ITEM_NAME)
   and whose contents come from the list of keymaps MAPS.  */
int
parse_single_submenu (Lisp_Object item_key, Lisp_Object item_name, Lisp_Object maps)
{
  Lisp_Object length;
  int len;
  Lisp_Object *mapvec;
  int i;
  int top_level_items = 0;

  length = Flength (maps);
  len = XINT (length);

  /* Convert the list MAPS into a vector MAPVEC.  */
  mapvec = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
  for (i = 0; i < len; i++)
    {
      mapvec[i] = Fcar (maps);
      maps = Fcdr (maps);
    }

  /* Loop over the given keymaps, making a pane for each map.
     But don't make a pane that is empty--ignore that map instead.  */
  for (i = 0; i < len; i++)
    {
      if (!KEYMAPP (mapvec[i]))
	{
	  /* Here we have a command at top level in the menu bar
	     as opposed to a submenu.  */
	  top_level_items = 1;
	  push_menu_pane (Qnil, Qnil);
	  push_menu_item (item_name, Qt, item_key, mapvec[i],
			  Qnil, Qnil, Qnil, Qnil);
	}
      else
	{
	  Lisp_Object prompt;
	  prompt = Fkeymap_prompt (mapvec[i]);
	  single_keymap_panes (mapvec[i],
			       !NILP (prompt) ? prompt : item_name,
			       item_key, 10);
	}
    }

  return top_level_items;
}
Ejemplo n.º 12
0
Archivo: menu.c Proyecto: ueno/emacs
/* Push all the panes and items of a menu described by the
   alist-of-alists MENU.
   This handles old-fashioned calls to x-popup-menu.  */
void
list_of_panes (Lisp_Object menu)
{
  Lisp_Object tail;

  init_menu_items ();

  for (tail = menu; CONSP (tail); tail = XCDR (tail))
    {
      Lisp_Object elt, pane_name, pane_data;
      elt = XCAR (tail);
      pane_name = Fcar (elt);
      CHECK_STRING (pane_name);
      push_menu_pane (encode_menu_string (pane_name), Qnil);
      pane_data = Fcdr (elt);
      CHECK_CONS (pane_data);
      list_of_items (pane_data);
    }

  finish_menu_items ();
}
Ejemplo n.º 13
0
void concatenate_to_non_list(CL_FORM *base, int nargs)
{
	Flist(STACK(base, 1), nargs - 1);
	LOAD_NIL(STACK(base, 2));
	LOAD_FIXNUM(0, STACK(base, 3));
	LOAD_FIXNUM(0, STACK(base, 4));
	LOAD_NIL(STACK(base, 5));
	COPY(STACK(base, 1), STACK(base, 6));
	M144_1:;
	if(CL_ATOMP(STACK(base, 6)))
	{
		LOAD_NIL(STACK(base, 5));
		goto RETURN158;
	}
	COPY(STACK(base, 6), STACK(base, 7));
	Fcar(STACK(base, 7));
	COPY(STACK(base, 7), STACK(base, 5));
	COPY(STACK(base, 3), STACK(base, 7));
	COPY(STACK(base, 5), STACK(base, 8));
	Flength(STACK(base, 8));
	Fplus(STACK(base, 7), 2);
	COPY(STACK(base, 7), STACK(base, 3));
	Fcdr(STACK(base, 6));
	goto M144_1;
	RETURN158:;
	COPY(STACK(base, 0), STACK(base, 5));
	COPY(STACK(base, 3), STACK(base, 6));
	Fmake_sequence(STACK(base, 5), 2);
	COPY(STACK(base, 5), STACK(base, 2));
	LOAD_NIL(STACK(base, 5));
	COPY(STACK(base, 1), STACK(base, 6));
	M145_1:;
	if(CL_ATOMP(STACK(base, 6)))
	{
		LOAD_NIL(STACK(base, 5));
		goto RETURN159;
	}
	COPY(STACK(base, 6), STACK(base, 7));
	Fcar(STACK(base, 7));
	COPY(STACK(base, 7), STACK(base, 5));
	if(CL_LISTP(STACK(base, 5)))
	{
		LOAD_NIL(STACK(base, 7));
		COPY(STACK(base, 5), STACK(base, 8));
		M146_1:;
		if(CL_ATOMP(STACK(base, 8)))
		{
			LOAD_NIL(STACK(base, 7));
			goto RETURN160;
		}
		COPY(STACK(base, 8), STACK(base, 9));
		Fcar(STACK(base, 9));
		COPY(STACK(base, 9), STACK(base, 7));
		COPY(STACK(base, 2), STACK(base, 10));
		COPY(STACK(base, 4), STACK(base, 11));
		Fset_elt(STACK(base, 9));
		COPY(STACK(base, 4), STACK(base, 9));
		F1plus(STACK(base, 9));
		COPY(STACK(base, 9), STACK(base, 4));
		Fcdr(STACK(base, 8));
		goto M146_1;
		RETURN160:;
	}
	else
	{
		COPY(STACK(base, 5), STACK(base, 7));
		Flength(STACK(base, 7));
		LOAD_FIXNUM(0, STACK(base, 8));
		M147_1:;
		COPY(STACK(base, 8), STACK(base, 9));
		COPY(STACK(base, 7), STACK(base, 10));
		Fge(STACK(base, 9), 2);
		if(CL_TRUEP(STACK(base, 9)))
		{
			goto RETURN161;
		}
		COPY(STACK(base, 5), STACK(base, 9));
		COPY(STACK(base, 8), STACK(base, 10));
		Felt(STACK(base, 9));
		COPY(STACK(base, 9), STACK(base, 10));
		COPY(STACK(base, 2), STACK(base, 11));
		COPY(STACK(base, 4), STACK(base, 12));
		Fset_elt(STACK(base, 10));
		COPY(STACK(base, 4), STACK(base, 9));
		F1plus(STACK(base, 9));
		COPY(STACK(base, 9), STACK(base, 4));
		F1plus(STACK(base, 8));
		goto M147_1;
		RETURN161:;
	}
	Fcdr(STACK(base, 6));
	goto M145_1;
	RETURN159:;
	COPY(STACK(base, 2), STACK(base, 0));
}
Ejemplo n.º 14
0
void
compute_fringe_widths (struct frame *f, int redraw)
{
  int o_left = FRAME_LEFT_FRINGE_WIDTH (f);
  int o_right = FRAME_RIGHT_FRINGE_WIDTH (f);
  int o_cols = FRAME_FRINGE_COLS (f);

  Lisp_Object left_fringe = Fassq (Qleft_fringe, f->param_alist);
  Lisp_Object right_fringe = Fassq (Qright_fringe, f->param_alist);
  int left_fringe_width, right_fringe_width;

  if (!NILP (left_fringe))
    left_fringe = Fcdr (left_fringe);
  if (!NILP (right_fringe))
    right_fringe = Fcdr (right_fringe);

  left_fringe_width = ((NILP (left_fringe) || !INTEGERP (left_fringe)) ? 8 :
		       XINT (left_fringe));
  right_fringe_width = ((NILP (right_fringe) || !INTEGERP (right_fringe)) ? 8 :
			XINT (right_fringe));

  if (left_fringe_width || right_fringe_width)
    {
      int left_wid = left_fringe_width >= 0 ? left_fringe_width : -left_fringe_width;
      int right_wid = right_fringe_width >= 0 ? right_fringe_width : -right_fringe_width;
      int conf_wid = left_wid + right_wid;
      int font_wid = FRAME_COLUMN_WIDTH (f);
      int cols = (left_wid + right_wid + font_wid-1) / font_wid;
      int real_wid = cols * font_wid;
      if (left_wid && right_wid)
	{
	  if (left_fringe_width < 0)
	    {
	      /* Left fringe width is fixed, adjust right fringe if necessary */
	      FRAME_LEFT_FRINGE_WIDTH (f) = left_wid;
	      FRAME_RIGHT_FRINGE_WIDTH (f) = real_wid - left_wid;
	    }
	  else if (right_fringe_width < 0)
	    {
	      /* Right fringe width is fixed, adjust left fringe if necessary */
	      FRAME_LEFT_FRINGE_WIDTH (f) = real_wid - right_wid;
	      FRAME_RIGHT_FRINGE_WIDTH (f) = right_wid;
	    }
	  else
	    {
	      /* Adjust both fringes with an equal amount.
		 Note that we are doing integer arithmetic here, so don't
		 lose a pixel if the total width is an odd number.  */
	      int fill = real_wid - conf_wid;
	      FRAME_LEFT_FRINGE_WIDTH (f) = left_wid + fill/2;
	      FRAME_RIGHT_FRINGE_WIDTH (f) = right_wid + fill - fill/2;
	    }
	}
      else if (left_fringe_width)
	{
	  FRAME_LEFT_FRINGE_WIDTH (f) = real_wid;
	  FRAME_RIGHT_FRINGE_WIDTH (f) = 0;
	}
      else
	{
	  FRAME_LEFT_FRINGE_WIDTH (f) = 0;
	  FRAME_RIGHT_FRINGE_WIDTH (f) = real_wid;
	}
      FRAME_FRINGE_COLS (f) = cols;
    }
  else
    {
      FRAME_LEFT_FRINGE_WIDTH (f) = 0;
      FRAME_RIGHT_FRINGE_WIDTH (f) = 0;
      FRAME_FRINGE_COLS (f) = 0;
    }

  if (redraw && FRAME_VISIBLE_P (f))
    if (o_left != FRAME_LEFT_FRINGE_WIDTH (f) ||
	o_right != FRAME_RIGHT_FRINGE_WIDTH (f) ||
	o_cols != FRAME_FRINGE_COLS (f))
      redraw_frame (f);
}
Ejemplo n.º 15
0
void unparse_unix_directory_list(CL_FORM *base)
{
	LOAD_NIL(STACK(base, 1));
	LOAD_NIL(STACK(base, 2));
	{
		CL_FORM *lptr;
		lptr = form_alloc(STACK(base, 3), 2);
		COPY(STACK(base, 1), CAR(lptr));
		COPY(STACK(base, 2), CDR(lptr));
		LOAD_CONS(lptr, STACK(base, 1));
	}
	if(CL_TRUEP(STACK(base, 0)))
	{
		COPY(STACK(base, 0), STACK(base, 2));
		Fcar(STACK(base, 2));
		COPY(STACK(base, 0), STACK(base, 3));
		COPY(STACK(base, 3), STACK(base, 4));
		Fcdr(STACK(base, 4));
		COPY(STACK(base, 4), STACK(base, 0));
		if(CL_SYMBOLP(STACK(base, 2)) && GET_SYMBOL(STACK(base, 2)) == SYMBOL(Slisp, 198))	/* ABSOLUTE */
		{
			LOAD_SMSTR((CL_FORM *)&Kunparse_unix_directory_list[0], STACK(base, 3));	/* / */
			COPY(STACK(base, 1), STACK(base, 4));
			add_q(STACK(base, 3));
		}
		else
		{
			if(CL_SYMBOLP(STACK(base, 2)) && GET_SYMBOL(STACK(base, 2)) == SYMBOL(Slisp, 201))	/* RELATIVE */
			{
				LOAD_T(STACK(base, 3));
			}
			else
			{
				LOAD_NIL(STACK(base, 3));
			}
			if(CL_TRUEP(STACK(base, 3)))
			{
			}
			else
			{
				LOAD_SMSTR((CL_FORM *)&Kunparse_unix_directory_list[2], STACK(base, 4));	/* ecase: the value ~a is not a legal value */
				COPY(STACK(base, 2), STACK(base, 5));
				Ferror(STACK(base, 4), 2);
			}
		}
		LOAD_NIL(STACK(base, 2));
		COPY(STACK(base, 0), STACK(base, 3));
		M33_1:;
		if(CL_ATOMP(STACK(base, 3)))
		{
			LOAD_NIL(STACK(base, 2));
			goto RETURN34;
		}
		COPY(STACK(base, 3), STACK(base, 4));
		Fcar(STACK(base, 4));
		COPY(STACK(base, 4), STACK(base, 2));
		if(CL_SYMBOLP(STACK(base, 2)) && GET_SYMBOL(STACK(base, 2)) == SYMBOL(Slisp, 205))	/* UP */
		{
			LOAD_SMSTR((CL_FORM *)&Kunparse_unix_directory_list[4], STACK(base, 4));	/* ../ */
			COPY(STACK(base, 1), STACK(base, 5));
			add_q(STACK(base, 4));
		}
		else
		{
			if(CL_SYMBOLP(STACK(base, 2)) && GET_SYMBOL(STACK(base, 2)) == SYMBOL(Slisp, 199))	/* BACK */
			{
				LOAD_SMSTR((CL_FORM *)&Kunparse_unix_directory_list[6], STACK(base, 4));	/* :BACK cannot be represented in namestrings. */
				Ferror(STACK(base, 4), 1);
			}
			else
			{
				if(CL_SMAR_P(STACK(base, 2)))
				{
					COPY(STACK(base, 2), STACK(base, 4));
					LOAD_SYMBOL(SYMBOL(Slisp, 43), STACK(base, 5));	/* STANDARD-CHAR */
					LOAD_SYMBOL(SYMBOL(Slisp, 48), STACK(base, 6));	/* * */
					check_array_internal(STACK(base, 4));
				}
				else
				{
					LOAD_NIL(STACK(base, 4));
				}
				if(CL_TRUEP(STACK(base, 4)))
				{
					bool_result = TRUE;
				}
				else
				{
					COPY(STACK(base, 2), STACK(base, 5));
					LOAD_SYMBOL(SYMBOL(Slisp, 181), STACK(base, 6));	/* PATTERN */
					struct_typep(STACK(base, 5));
					bool_result = CL_TRUEP(STACK(base, 5));
				}
				if(bool_result)
				{
					COPY(STACK(base, 2), STACK(base, 4));
					unparse_unix_piece(STACK(base, 4));
					COPY(STACK(base, 1), STACK(base, 5));
					add_q(STACK(base, 4));
					LOAD_SMSTR((CL_FORM *)&Kunparse_unix_directory_list[8], STACK(base, 4));	/* / */
					COPY(STACK(base, 1), STACK(base, 5));
					add_q(STACK(base, 4));
				}
				else
				{
					LOAD_SMSTR((CL_FORM *)&Kunparse_unix_directory_list[10], STACK(base, 4));	/* Invalid directory component: ~S */
					COPY(STACK(base, 2), STACK(base, 5));
					Ferror(STACK(base, 4), 2);
				}
			}
		}
		Fcdr(STACK(base, 3));
		goto M33_1;
		RETURN34:;
	}
	LOAD_GLOBFUN(&CFconcatenate, STACK(base, 2));
	LOAD_SYMBOL(SYMBOL(Slisp, 40), STACK(base, 3));	/* SIMPLE-STRING */
	COPY(STACK(base, 1), STACK(base, 4));
	Fcar(STACK(base, 4));
	Fapply(STACK(base, 2), 3);
	COPY(STACK(base, 2), STACK(base, 0));
}
Ejemplo n.º 16
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.º 17
0
void concatenate_to_list(CL_FORM *base, int nargs)
{
	Flist(STACK(base, 0), nargs - 0);
	LOAD_NIL(STACK(base, 1));
	LOAD_NIL(STACK(base, 2));
	{
		CL_FORM *lptr;
		lptr = form_alloc(STACK(base, 3), 2);
		COPY(STACK(base, 1), CAR(lptr));
		COPY(STACK(base, 2), CDR(lptr));
		LOAD_CONS(lptr, STACK(base, 1));
	}
	LOAD_NIL(STACK(base, 2));
	COPY(STACK(base, 0), STACK(base, 3));
	M148_1:;
	if(CL_ATOMP(STACK(base, 3)))
	{
		LOAD_NIL(STACK(base, 2));
		goto RETURN162;
	}
	COPY(STACK(base, 3), STACK(base, 4));
	Fcar(STACK(base, 4));
	COPY(STACK(base, 4), STACK(base, 2));
	if(CL_LISTP(STACK(base, 2)))
	{
		LOAD_NIL(STACK(base, 4));
		COPY(STACK(base, 2), STACK(base, 5));
		M149_1:;
		if(CL_ATOMP(STACK(base, 5)))
		{
			LOAD_NIL(STACK(base, 4));
			goto RETURN163;
		}
		COPY(STACK(base, 5), STACK(base, 6));
		Fcar(STACK(base, 6));
		COPY(STACK(base, 6), STACK(base, 4));
		COPY(STACK(base, 1), STACK(base, 7));
		add_q(STACK(base, 6));
		Fcdr(STACK(base, 5));
		goto M149_1;
		RETURN163:;
	}
	else
	{
		COPY(STACK(base, 2), STACK(base, 4));
		Flength(STACK(base, 4));
		LOAD_FIXNUM(0, STACK(base, 5));
		M150_1:;
		COPY(STACK(base, 5), STACK(base, 6));
		COPY(STACK(base, 4), STACK(base, 7));
		Fge(STACK(base, 6), 2);
		if(CL_TRUEP(STACK(base, 6)))
		{
			goto RETURN164;
		}
		COPY(STACK(base, 2), STACK(base, 6));
		COPY(STACK(base, 5), STACK(base, 7));
		Felt(STACK(base, 6));
		COPY(STACK(base, 1), STACK(base, 7));
		add_q(STACK(base, 6));
		F1plus(STACK(base, 5));
		goto M150_1;
		RETURN164:;
	}
	Fcdr(STACK(base, 3));
	goto M148_1;
	RETURN162:;
	COPY(STACK(base, 1), STACK(base, 0));
	Fcar(STACK(base, 0));
}