Initial revision

src/casefiddle.c

@@ -0,0 +1,268 @@
+/* GNU Emacs case conversion functions.
+   Copyright (C) 1985 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING.  If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+
+#include "config.h"
+#include "lisp.h"
+#include "buffer.h"
+#include "commands.h"
+#include "syntax.h"
+
+enum case_action {CASE_UP, CASE_DOWN, CASE_CAPITALIZE, CASE_CAPITALIZE_UP};
+
+Lisp_Object
+casify_object (flag, obj)
+     enum case_action flag;
+     Lisp_Object obj;
+{
+  register int i, c, len;
+  register int inword = flag == CASE_DOWN;
+
+  while (1)
+    {
+      if (XTYPE (obj) == Lisp_Int)
+	{
+	  c = XINT (obj);
+	  if (c >= 0 && c <= 0400)
+	    {
+	      if (inword)
+		XFASTINT (obj) = DOWNCASE (c);
+	      else if (!UPPERCASEP (c))
+		XFASTINT (obj) = UPCASE1 (c);
+	    }
+	  return obj;
+	}
+      if (XTYPE (obj) == Lisp_String)
+	{
+	  obj = Fcopy_sequence (obj);
+	  len = XSTRING (obj)->size;
+	  for (i = 0; i < len; i++)
+	    {
+	      c = XSTRING (obj)->data[i];
+	      if (inword)
+		c = DOWNCASE (c);
+	      else if (!UPPERCASEP (c))
+		c = UPCASE1 (c);
+	      XSTRING (obj)->data[i] = c;
+	      if (flag == CASE_CAPITALIZE)
+		inword = SYNTAX (c) == Sword;
+	    }
+	  return obj;
+	}
+      obj = wrong_type_argument (Qchar_or_string_p, obj, 0);
+    }
+}
+
+DEFUN ("upcase", Fupcase, Supcase, 1, 1, 0,
+  "Convert argument to upper case and return that.\n\
+The argument may be a character or string.  The result has the same type.\n\
+The argument object is not altered.  See also `capitalize'.")
+  (obj)
+     Lisp_Object obj;
+{
+  return casify_object (CASE_UP, obj);
+}
+
+DEFUN ("downcase", Fdowncase, Sdowncase, 1, 1, 0,
+  "Convert argument to lower case and return that.\n\
+The argument may be a character or string.  The result has the same type.\n\
+The argument object is not altered.")
+  (obj)
+     Lisp_Object obj;
+{
+  return casify_object (CASE_DOWN, obj);
+}
+
+DEFUN ("capitalize", Fcapitalize, Scapitalize, 1, 1, 0,
+  "Convert argument to capitalized form and return that.\n\
+This means that each word's first character is upper case\n\
+and the rest is lower case.\n\
+The argument may be a character or string.  The result has the same type.\n\
+The argument object is not altered.")
+  (obj)
+     Lisp_Object obj;
+{
+  return casify_object (CASE_CAPITALIZE, obj);
+}
+
+/* flag is CASE_UP, CASE_DOWN or CASE_CAPITALIZE or CASE_CAPITALIZE_UP.
+   b and e specify range of buffer to operate on. */
+
+casify_region (flag, b, e)
+     enum case_action flag;
+     Lisp_Object b, e;
+{
+  register int i;
+  register int c;
+  register int inword = flag == CASE_DOWN;
+
+  if (EQ (b, e))
+    /* Not modifying because nothing marked */
+    return;
+
+  validate_region (&b, &e);
+  modify_region (XFASTINT (b), XFASTINT (e));
+  record_change (XFASTINT (b), XFASTINT (e) - XFASTINT (b));
+
+  for (i = XFASTINT (b); i < XFASTINT (e); i++)
+    {
+      c = FETCH_CHAR (i);
+      if (inword && flag != CASE_CAPITALIZE_UP)
+	c = DOWNCASE (c);
+      else if (!UPPERCASEP (c)
+	       && (!inword || flag != CASE_CAPITALIZE_UP))
+	c = UPCASE1 (c);
+      FETCH_CHAR (i) = c;
+      if ((int) flag >= (int) CASE_CAPITALIZE)
+	inword = SYNTAX (c) == Sword;
+    }
+
+  signal_after_change (XFASTINT (b),
+		       XFASTINT (e) - XFASTINT (b), 
+		       XFASTINT (e) - XFASTINT (b));
+}
+
+DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 2, "r",
+  "Convert the region to upper case.  In programs, wants two arguments.\n\
+These arguments specify the starting and ending character numbers of\n\
+the region to operate on.  When used as a command, the text between\n\
+point and the mark is operated on.\n\
+See also `capitalize-region'.")
+  (b, e)
+     Lisp_Object b, e;
+{
+  casify_region (CASE_UP, b, e);
+  return Qnil;
+}
+
+DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 2, "r",
+  "Convert the region to lower case.  In programs, wants two arguments.\n\
+These arguments specify the starting and ending character numbers of\n\
+the region to operate on.  When used as a command, the text between\n\
+point and the mark is operated on.")
+  (b, e)
+     Lisp_Object b, e;
+{
+  casify_region (CASE_DOWN, b, e);
+  return Qnil;
+}
+
+DEFUN ("capitalize-region", Fcapitalize_region, Scapitalize_region, 2, 2, "r",
+  "Convert the region to capitalized form.\n\
+Capitalized form means each word's first character is upper case\n\
+and the rest of it is lower case.\n\
+In programs, give two arguments, the starting and ending\n\
+character positions to operate on.")
+  (b, e)
+     Lisp_Object b, e;
+{
+  casify_region (CASE_CAPITALIZE, b, e);
+  return Qnil;
+}
+
+/* Like Fcapitalize but change only the initials.  */
+
+Lisp_Object
+upcase_initials_region (b, e)
+     Lisp_Object b, e;
+{
+  casify_region (CASE_CAPITALIZE_UP, b, e);
+  return Qnil;
+}
+
+Lisp_Object
+operate_on_word (arg)
+     Lisp_Object arg;
+{
+  Lisp_Object val, end;
+  int farend;
+
+  CHECK_NUMBER (arg, 0);
+  farend = scan_words (point, XINT (arg));
+  if (!farend)
+    farend = XINT (arg) > 0 ? ZV : BEGV;
+
+  end = point > farend ? point : farend;
+  SET_PT (end);
+  XFASTINT (val) = farend;
+
+  return val;
+}
+
+DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p",
+  "Convert following word (or ARG words) to upper case, moving over.\n\
+With negative argument, convert previous words but do not move.\n\
+See also `capitalize-word'.")
+  (arg)
+     Lisp_Object arg;
+{
+  Lisp_Object opoint;
+
+  XFASTINT (opoint) = point;
+  casify_region (CASE_UP, opoint, operate_on_word (arg));
+  return Qnil;
+}
+
+DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
+  "Convert following word (or ARG words) to lower case, moving over.\n\
+With negative argument, convert previous words but do not move.")
+  (arg)
+     Lisp_Object arg;
+{
+  Lisp_Object opoint;
+  XFASTINT (opoint) = point;
+  casify_region (CASE_DOWN, opoint, operate_on_word (arg));
+  return Qnil;
+}
+
+DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
+  "Capitalize the following word (or ARG words), moving over.\n\
+This gives the word(s) a first character in upper case\n\
+and the rest lower case.\n\
+With negative argument, capitalize previous words but do not move.")
+  (arg)
+     Lisp_Object arg;
+{
+  Lisp_Object opoint;
+  XFASTINT (opoint) = point;
+  casify_region (CASE_CAPITALIZE, opoint, operate_on_word (arg));
+  return Qnil;
+}
+
+syms_of_casefiddle ()
+{
+  defsubr (&Supcase);
+  defsubr (&Sdowncase);
+  defsubr (&Scapitalize);
+  defsubr (&Supcase_region);
+  defsubr (&Sdowncase_region);
+  defsubr (&Scapitalize_region);
+  defsubr (&Supcase_word);
+  defsubr (&Sdowncase_word);
+  defsubr (&Scapitalize_word);
+}
+
+keys_of_casefiddle ()
+{
+  initial_define_key (control_x_map, Ctl('U'), "upcase-region");
+  initial_define_key (control_x_map, Ctl('L'), "downcase-region");
+  initial_define_key (meta_map, 'u', "upcase-word");
+  initial_define_key (meta_map, 'l', "downcase-word");
+  initial_define_key (meta_map, 'c', "capitalize-word");
+}

src/casetab.c

@@ -0,0 +1,250 @@
+/* GNU Emacs routines to deal with case tables.
+   Copyright (C) 1987 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING.  If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+/* Written by Howard Gayle.  See chartab.c for details. */
+
+#include "config.h"
+#include "lisp.h"
+#include "buffer.h"
+
+Lisp_Object Qcase_table_p;
+Lisp_Object Vascii_downcase_table, Vascii_upcase_table;
+Lisp_Object Vascii_canon_table, Vascii_eqv_table;
+
+void compute_trt_inverse ();
+
+DEFUN ("case-table-p", Fcase_table_p, Scase_table_p, 1, 1, 0,
+  "Return t iff ARG is a case table.\n\
+See `set-case-table' for more information on these data structures.")
+  (table)
+     Lisp_Object table;
+{
+  Lisp_Object down, up, canon, eqv;
+  down = Fcar_safe (table);
+  up = Fcar_safe (Fcdr_safe (table));
+  canon = Fcar_safe (Fcdr_safe (Fcdr_safe (table)));
+  eqv = Fcar_safe (Fcdr_safe (Fcdr_safe (Fcdr_safe (table))));
+
+#define STRING256_P(obj) \
+  (XTYPE (obj) == Lisp_String && XSTRING (obj)->size == 256)
+
+  return (STRING256_P (down)
+	  && (NULL (up) || STRING256_P (up))
+	  && ((NULL (canon) && NULL (eqv))
+	      || (STRING256_P (canon) && STRING256_P (eqv)))
+	  ? Qt : Qnil);
+}
+
+static Lisp_Object
+check_case_table (obj)
+     Lisp_Object obj;
+{
+  register Lisp_Object tem;
+
+  while (tem = Fcase_table_p (obj), NULL (tem))
+    obj = wrong_type_argument (Qcase_table_p, obj, 0);
+  return (obj);
+}   
+
+DEFUN ("current-case-table", Fcurrent_case_table, Scurrent_case_table, 0, 0, 0,
+  "Return the case table of the current buffer.")
+  ()
+{
+  Lisp_Object down, up, canon, eqv;
+  
+  down = current_buffer->downcase_table;
+  up = current_buffer->upcase_table;
+  canon = current_buffer->case_canon_table;
+  eqv = current_buffer->case_eqv_table;
+
+  return Fcons (down, Fcons (up, Fcons (canon, Fcons (eqv, Qnil))));
+}
+
+DEFUN ("standard-case-table", Fstandard_case_table,
+  Sstandard_case_table, 0, 0, 0,
+  "Return the standard case table.\n\
+This is the one used for new buffers.")
+  ()
+{
+  return Fcons (Vascii_downcase_table,
+		Fcons (Vascii_upcase_table,
+		       Fcons (Vascii_canon_table,
+			      Fcons (Vascii_eqv_table, Qnil))));
+}
+
+DEFUN ("set-case-table", Fset_case_table, Sset_case_table, 1, 1, 0,
+  "Select a new case table for the current buffer.\n\
+A case table is a list (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES)\n\
+ where each element is either nil or a string of length 256.\n\
+DOWNCASE maps each character to its lower-case equivalent.\n\
+UPCASE maps each character to its upper-case equivalent;\n\
+ if lower and upper case characters are in 1-1 correspondence,\n\
+ you may use nil and the upcase table will be deduced from DOWNCASE.\n\
+CANONICALIZE maps each character to a canonical equivalent;\n\
+ any two characters that are related by case-conversion have the same\n\
+ canonical equivalent character.\n\
+EQUIVALENCES is a map that cyclicly permutes each equivalence class\n\
+ (of characters with the same canonical equivalent).\n\
+Both CANONICALIZE and EQUIVALENCES may be nil, in which case\n\
+ both are deduced from DOWNCASE and UPCASE.")
+  (table)
+     Lisp_Object table;
+{
+  set_case_table (table, 0);
+}
+
+DEFUN ("set-standard-case-table",
+       Fset_standard_case_table, Sset_standard_case_table, 1, 1, 0,
+  "Select a new standard case table for new buffers.\n\
+See `set-case-table' for more info on case tables.")
+  (table)
+     Lisp_Object table;
+{
+  set_case_table (table, 1);
+}
+
+set_case_table (table, standard)
+     Lisp_Object table;
+     int standard;
+{
+  Lisp_Object down, up, canon, eqv;
+
+  check_case_table (table);
+
+  down = Fcar_safe (table);
+  up = Fcar_safe (Fcdr_safe (table));
+  canon = Fcar_safe (Fcdr_safe (Fcdr_safe (table)));
+  eqv = Fcar_safe (Fcdr_safe (Fcdr_safe (Fcdr_safe (table))));
+
+  if (NULL (up))
+    {
+      up = Fmake_string (make_number (256), make_number (0));
+      compute_trt_inverse (XSTRING (down)->data, XSTRING (up)->data);
+    }
+
+  if (NULL (canon))
+    {
+      register int i;
+      unsigned char *upvec = XSTRING (up)->data;
+      unsigned char *downvec = XSTRING (down)->data;
+
+      canon = Fmake_string (make_number (256), make_number (0));
+      eqv = Fmake_string (make_number (256), make_number (0));
+
+      /* Set up the CANON vector; for each character,
+	 this sequence of upcasing and downcasing ought to
+	 get the "preferred" lowercase equivalent.  */
+      for (i = 0; i < 256; i++)
+	XSTRING (canon)->data[i] = downvec[upvec[downvec[i]]];
+
+      compute_trt_inverse (XSTRING (canon)->data, XSTRING (eqv)->data);
+    }
+
+  if (standard)
+    {
+      Vascii_downcase_table = down;
+      Vascii_upcase_table = up;
+      Vascii_canon_table = canon;
+      Vascii_eqv_table = eqv;
+    }
+  else
+    {
+      current_buffer->downcase_table = down;
+      current_buffer->upcase_table = up;
+      current_buffer->case_canon_table = canon;
+      current_buffer->case_eqv_table = eqv;
+    }
+  return table;
+}
+
+/* Given a translate table TRT, store the inverse mapping into INVERSE.
+   Since TRT is not one-to-one, INVERSE is not a simple mapping.
+   Instead, it divides the space of characters into equivalence classes.
+   All characters in a given class form one circular list, chained through
+   the elements of INVERSE.  */
+
+void
+compute_trt_inverse (trt, inverse)
+     register unsigned char *trt;
+     register unsigned char *inverse;
+{
+  register int i = 0400;
+  register unsigned char c, q;
+
+  while (i--)
+    inverse[i] = i;
+  i = 0400;
+  while (i--)
+    {
+      if ((q = trt[i]) != (unsigned char) i)
+	{
+	  c = inverse[q];
+	  inverse[q] = i;
+	  inverse[i] = c;
+	}
+    }
+}
+
+init_casetab_once ()
+{
+  register int i;
+  Lisp_Object tem;
+
+  tem = Fmake_string (make_number (256), make_number (0));
+  Vascii_downcase_table = tem;
+  Vascii_canon_table = tem;
+
+  for (i = 0; i < 256; i++)
+    XSTRING (tem)->data[i] = (i >= 'A' && i <= 'Z') ? i + 040 : i;
+
+  tem = Fmake_string (make_number (256), make_number (0));
+  Vascii_upcase_table = tem;
+  Vascii_eqv_table = tem;
+
+  for (i = 0; i < 256; i++)
+    XSTRING (tem)->data[i]
+      = ((i >= 'A' && i <= 'Z')
+	 ? i + ('a' - 'A')
+	 : ((i >= 'a' && i <= 'z')
+	    ? i + ('A' - 'a')
+	    : i));
+}
+
+syms_of_casetab ()
+{
+  Qcase_table_p = intern ("case-table-p");
+  staticpro (&Qcase_table_p);
+  staticpro (&Vascii_downcase_table);
+  staticpro (&Vascii_upcase_table);
+  staticpro (&Vascii_canon_table);
+  staticpro (&Vascii_eqv_table);
+
+  defsubr (&Scase_table_p);
+  defsubr (&Scurrent_case_table);
+  defsubr (&Sstandard_case_table);
+  defsubr (&Sset_case_table);
+  defsubr (&Sset_standard_case_table);
+
+#if 0
+  DEFVAR_LISP ("ascii-downcase-table", &Vascii_downcase_table,
+	       "String mapping ASCII characters to lowercase equivalents.");
+  DEFVAR_LISP ("ascii-upcase-table", &Vascii_upcase_table,
+	       "String mapping ASCII characters to uppercase equivalents.");
+#endif
+}

src/marker.c

@@ -0,0 +1,295 @@
+/* Markers: examining, setting and killing.
+   Copyright (C) 1985 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING.  If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+
+#include "config.h"
+#include "lisp.h"
+#include "buffer.h"
+
+/* Operations on markers. */
+
+DEFUN ("marker-buffer", Fmarker_buffer, Smarker_buffer, 1, 1, 0,
+  "Return the buffer that MARKER points into, or nil if none.\n\
+Returns nil if MARKER points into a dead buffer.")
+  (marker)
+     register Lisp_Object marker;
+{
+  register Lisp_Object buf;
+  CHECK_MARKER (marker, 0);
+  if (XMARKER (marker)->buffer)
+    {
+      XSET (buf, Lisp_Buffer, XMARKER (marker)->buffer);
+      /* Return marker's buffer only if it is not dead.  */
+      if (!NULL (XBUFFER (buf)->name))
+	return buf;
+    }
+  return Qnil;
+}
+
+DEFUN ("marker-position", Fmarker_position, Smarker_position, 1, 1, 0,
+  "Return the position MARKER points at, as a character number.")
+  (marker)
+     Lisp_Object marker;
+{
+  register Lisp_Object pos;
+  register int i;
+  register struct buffer *buf;
+
+  CHECK_MARKER (marker, 0);
+  if (XMARKER (marker)->buffer)
+    {
+      buf = XMARKER (marker)->buffer;
+      i = XMARKER (marker)->bufpos;
+
+      if (i > BUF_GPT (buf) + BUF_GAP_SIZE (buf))
+	i -= BUF_GAP_SIZE (buf);
+      else if (i > BUF_GPT (buf))
+	i = BUF_GPT (buf);
+
+      if (i < BUF_BEG (buf) || i > BUF_Z (buf))
+	abort ();
+
+      XFASTINT (pos) = i;
+      return pos;
+    }
+  return Qnil;
+}
+
+DEFUN ("set-marker", Fset_marker, Sset_marker, 2, 3, 0,
+  "Position MARKER before character number NUMBER in BUFFER.\n\
+BUFFER defaults to the current buffer.\n\
+If NUMBER is nil, makes marker point nowhere.\n\
+Then it no longer slows down editing in any buffer.\n\
+Returns MARKER.")
+  (marker, pos, buffer)
+     Lisp_Object marker, pos, buffer;
+{
+  register int charno;
+  register struct buffer *b;
+  register struct Lisp_Marker *m;
+
+  CHECK_MARKER (marker, 0);
+  /* If position is nil or a marker that points nowhere,
+     make this marker point nowhere.  */
+  if (NULL (pos)
+      || (XTYPE (pos) == Lisp_Marker && !XMARKER (pos)->buffer))
+    {
+      unchain_marker (marker);
+      return marker;
+    }
+
+  CHECK_NUMBER_COERCE_MARKER (pos, 1);
+  if (NULL (buffer))
+    b = current_buffer;
+  else
+    {
+      CHECK_BUFFER (buffer, 1);
+      b = XBUFFER (buffer);
+      /* If buffer is dead, set marker to point nowhere.  */
+      if (EQ (b->name, Qnil))
+	{
+	  unchain_marker (marker);
+	  return marker;
+	}
+    }
+
+  charno = XINT (pos);
+  m = XMARKER (marker);
+
+  if (charno < BUF_BEG (b))
+    charno = BUF_BEG (b);
+  if (charno > BUF_Z (b))
+    charno = BUF_Z (b);
+  if (charno > BUF_GPT (b)) charno += BUF_GAP_SIZE (b);
+  m->bufpos = charno;
+
+  if (m->buffer != b)
+    {
+      unchain_marker (marker);
+      m->chain = b->markers;
+      b->markers = marker;
+      m->buffer = b;
+    }
+  
+  return marker;
+}
+
+/* This version of Fset_marker won't let the position
+   be outside the visible part.  */
+
+Lisp_Object 
+set_marker_restricted (marker, pos, buffer)
+     Lisp_Object marker, pos, buffer;
+{
+  register int charno;
+  register struct buffer *b;
+  register struct Lisp_Marker *m;
+
+  CHECK_MARKER (marker, 0);
+  /* If position is nil or a marker that points nowhere,
+     make this marker point nowhere.  */
+  if (NULL (pos) ||
+      (XTYPE (pos) == Lisp_Marker && !XMARKER (pos)->buffer))
+    {
+      unchain_marker (marker);
+      return marker;
+    }
+
+  CHECK_NUMBER_COERCE_MARKER (pos, 1);
+  if (NULL (buffer))
+    b = current_buffer;
+  else
+    {
+      CHECK_BUFFER (buffer, 1);
+      b = XBUFFER (buffer);
+      /* If buffer is dead, set marker to point nowhere.  */
+      if (EQ (b->name, Qnil))
+	{
+	  unchain_marker (marker);
+	  return marker;
+	}
+    }
+
+  charno = XINT (pos);
+  m = XMARKER (marker);
+
+  if (charno < BUF_BEGV (b))
+    charno = BUF_BEGV (b);
+  if (charno > BUF_ZV (b))
+    charno = BUF_ZV (b);
+  if (charno > BUF_GPT (b))
+    charno += BUF_GAP_SIZE (b);
+  m->bufpos = charno;
+
+  if (m->buffer != b)
+    {
+      unchain_marker (marker);
+      m->chain = b->markers;
+      b->markers = marker;
+      m->buffer = b;
+    }
+  
+  return marker;
+}
+
+/* This is called during garbage collection,
+   so we must be careful to ignore and preserve mark bits,
+   including those in chain fields of markers.  */
+
+unchain_marker (marker)
+     register Lisp_Object marker;
+{
+  register Lisp_Object tail, prev, next;
+  register int omark;
+  register struct buffer *b;
+
+  b = XMARKER (marker)->buffer;
+  if (b == 0)
+    return;
+
+  if (EQ (b->name, Qnil))
+    abort ();
+
+  tail = b->markers;
+  prev = Qnil;
+  while (XSYMBOL (tail) != XSYMBOL (Qnil))
+    {
+      next = XMARKER (tail)->chain;
+      XUNMARK (next);
+
+      if (XMARKER (marker) == XMARKER (tail))
+	{
+	  if (NULL (prev))
+	    {
+	      b->markers = next;
+	      /* Deleting first marker from the buffer's chain.
+		 Crash if new first marker in chain does not say
+		 it belongs to this buffer.  */
+	      if (!EQ (next, Qnil) && b != XMARKER (next)->buffer)
+		abort ();
+	    }
+	  else
+	    {
+	      omark = XMARKBIT (XMARKER (prev)->chain);
+	      XMARKER (prev)->chain = next;
+	      XSETMARKBIT (XMARKER (prev)->chain, omark);
+	    }
+	  break;
+	}
+      else
+	prev = tail;
+      tail = next;
+    }
+  XMARKER (marker)->buffer = 0;
+}
+
+marker_position (marker)
+     Lisp_Object marker;
+{
+  register struct Lisp_Marker *m = XMARKER (marker);
+  register struct buffer *buf = m->buffer;
+  register int i = m->bufpos;
+
+  if (!buf)
+    error ("Marker does not point anywhere");
+
+  if (i > BUF_GPT (buf) + BUF_GAP_SIZE (buf))
+    i -= BUF_GAP_SIZE (buf);
+  else if (i > BUF_GPT (buf))
+    i = BUF_GPT (buf);
+
+  if (i < BUF_BEG (buf) || i > BUF_Z (buf))
+    abort ();
+
+  return i;
+}
+
+DEFUN ("copy-marker", Fcopy_marker, Scopy_marker, 1, 1, 0,
+  "Return a new marker pointing at the same place as MARKER.\n\
+If argument is a number, makes a new marker pointing\n\
+at that position in the current buffer.")
+  (marker)
+     register Lisp_Object marker;
+{
+  register Lisp_Object new;
+
+  while (1)
+    {
+      if (XTYPE (marker) == Lisp_Int
+	  || XTYPE (marker) == Lisp_Marker)
+	{
+	  new = Fmake_marker ();
+	  Fset_marker (new, marker,
+		       ((XTYPE (marker) == Lisp_Marker)
+			? Fmarker_buffer (marker)
+			: Qnil));
+	  return new;
+	}
+      else
+	marker = wrong_type_argument (Qinteger_or_marker_p, marker);
+    }
+}
+
+syms_of_marker ()
+{
+  defsubr (&Smarker_position);
+  defsubr (&Smarker_buffer);
+  defsubr (&Sset_marker);
+  defsubr (&Scopy_marker);
+}

src/ralloc.c

@@ -0,0 +1,426 @@
+/* Block-relocating memory allocator. 
+   Copyright (C) 1990 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING.  If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+/* NOTES:
+
+   Only relocate the blocs neccessary for SIZE in r_alloc_sbrk,
+   rather than all of them.  This means allowing for a possible
+   hole between the first bloc and the end of malloc storage. */
+
+#include "config.h"
+#include "lisp.h"		/* Needed for xterm.h */
+#undef NULL
+#include "mem_limits.h"
+#include "xterm.h"		/* Needed for BLOCK_INPUT */
+
+#define NIL ((POINTER) 0)
+
+
+/* System call to set the break value. */
+extern POINTER sbrk ();
+
+/* The break value, as seen by malloc (). */
+static POINTER virtual_break_value;
+
+/* The break value, viewed by the relocatable blocs. */
+static POINTER break_value;
+
+/* The REAL (i.e., page aligned) break value of the process. */
+static POINTER page_break_value;
+
+/* Macros for rounding.  Note that rounding to any value is possible
+   by changing the definition of PAGE. */
+#define PAGE (getpagesize ())
+#define ALIGNED(addr) (((unsigned int) (addr) & (PAGE - 1)) == 0)
+#define ROUNDUP(size) (((unsigned int) (size) + PAGE) & ~(PAGE - 1))
+#define ROUND_TO_PAGE(addr) (addr & (~(PAGE - 1)))
+#define EXCEEDS_ELISP_PTR(ptr) ((unsigned int) (ptr) >> VALBITS)
+
+/* Level of warnings issued. */
+static int warnlevel;
+
+/* Function to call to issue a warning;
+   0 means don't issue them.  */
+static void (*warnfunction) ();
+
+static void
+check_memory_limits (address)
+     POINTER address;
+{
+  SIZE data_size = address - data_space_start;
+
+  switch (warnlevel)
+    {
+    case 0: 
+      if (data_size > (lim_data / 4) * 3)
+	{
+	  warnlevel++;
+	  (*warnfunction) ("Warning: past 75% of memory limit");
+	}
+      break;
+
+    case 1: 
+      if (data_size > (lim_data / 20) * 17)
+	{
+	  warnlevel++;
+	  (*warnfunction) ("Warning: past 85% of memory limit");
+	}
+      break;
+
+    case 2: 
+      if (data_size > (lim_data / 20) * 19)
+	{
+	  warnlevel++;
+	  (*warnfunction) ("Warning: past 95% of memory limit");
+	}
+      break;
+
+    default:
+      (*warnfunction) ("Warning: past acceptable memory limits");
+      break;
+    }
+
+    if (EXCEEDS_ELISP_PTR (address))
+      (*warnfunction) ("Warning: memory in use exceeds lisp pointer size");
+}
+
+/* Obtain SIZE bytes of space.  If enough space is not presently available
+   in our process reserve, (i.e., (page_break_value - break_value)),
+   this means getting more page-aligned space from the system. */
+
+static void
+obtain (size)
+     SIZE size;
+{
+  SIZE already_available = page_break_value - break_value;
+
+  if (already_available < size)
+    {
+      SIZE get = ROUNDUP (size);
+
+      if (warnfunction)
+	check_memory_limits (page_break_value);
+
+      if (((int) sbrk (get)) < 0)
+	abort ();
+
+      page_break_value += get;
+    }
+
+  break_value += size;
+}
+
+/* Obtain SIZE bytes of space and return a pointer to the new area. */
+
+static POINTER
+get_more_space (size)
+     SIZE size;
+{
+  POINTER ptr = break_value;
+  obtain (size);
+  return ptr;
+}
+
+/* Note that SIZE bytes of space have been relinquished by the process.
+   If SIZE is more than a page, return the space the system. */
+
+static void
+relinquish (size)
+     SIZE size;
+{
+  SIZE page_part = ROUND_TO_PAGE (size);
+
+  if (page_part)
+    {
+      if (((int) (sbrk (- page_part))) < 0)
+	abort ();
+
+      page_break_value -= page_part;
+    }
+
+  break_value -= size;
+  bzero (break_value, (size - page_part));
+}
+
+typedef struct bp
+{
+  struct bp *next;
+  struct bp *prev;
+  POINTER *variable;
+  POINTER data;
+  SIZE size;
+} *bloc_ptr;
+
+#define NIL_BLOC ((bloc_ptr) 0)
+#define BLOC_PTR_SIZE (sizeof (struct bp))
+
+/* Head and tail of the list of relocatable blocs. */
+static bloc_ptr first_bloc, last_bloc;
+
+/* Declared in dispnew.c, this version dosen't fuck up if regions overlap. */
+extern void safe_bcopy ();
+
+/* Find the bloc reference by the address in PTR.  Returns a pointer
+   to that block. */
+
+static bloc_ptr
+find_bloc (ptr)
+     POINTER *ptr;
+{
+  register bloc_ptr p = first_bloc;
+
+  while (p != NIL_BLOC)
+    {
+      if (p->variable == ptr && p->data == *ptr)
+	return p;
+
+      p = p->next;
+    }
+
+  return p;
+}
+
+/* Allocate a bloc of SIZE bytes and append it to the chain of blocs.
+   Returns a pointer to the new bloc. */
+
+static bloc_ptr
+get_bloc (size)
+     SIZE size;
+{
+  register bloc_ptr new_bloc = (bloc_ptr) malloc (BLOC_PTR_SIZE);
+
+  new_bloc->data = get_more_space (size);
+  new_bloc->size = size;
+  new_bloc->next = NIL_BLOC;
+  new_bloc->variable = NIL;
+
+  if (first_bloc)
+    {
+      new_bloc->prev = last_bloc;
+      last_bloc->next = new_bloc;
+      last_bloc = new_bloc;
+    }
+  else
+    {
+      first_bloc = last_bloc = new_bloc;
+      new_bloc->prev = NIL_BLOC;
+    }
+
+  return new_bloc;
+}
+
+/* Relocate all blocs from BLOC on upward in the list to the zone
+   indicated by ADDRESS.  Direction of relocation is determined by
+   the position of ADDRESS relative to BLOC->data.
+
+   Note that ordering of blocs is not affected by this function. */
+
+static void
+relocate_some_blocs (bloc, address)
+     bloc_ptr bloc;
+     POINTER address;
+{
+  register bloc_ptr b;
+  POINTER data_zone = bloc->data;
+  register SIZE data_zone_size = 0;
+  register SIZE offset = bloc->data - address;
+  POINTER new_data_zone = data_zone - offset;
+
+  for (b = bloc; b != NIL_BLOC; b = b->next)
+    {
+      data_zone_size += b->size;
+      b->data -= offset;
+      *b->variable = b->data;
+    }
+
+  safe_bcopy (data_zone, new_data_zone, data_zone_size);
+}
+
+/* Free BLOC from the chain of blocs, relocating any blocs above it
+   and returning BLOC->size bytes to the free area. */
+
+static void
+free_bloc (bloc)
+     bloc_ptr bloc;
+{
+  if (bloc == first_bloc && bloc == last_bloc)
+    {
+      first_bloc = last_bloc = NIL_BLOC;
+    }
+  else if (bloc == last_bloc)
+    {
+      last_bloc = bloc->prev;
+      last_bloc->next = NIL_BLOC;
+    }
+  else if (bloc == first_bloc)
+    {
+      first_bloc = bloc->next;
+      first_bloc->prev = NIL_BLOC;
+      relocate_some_blocs (bloc->next, bloc->data);
+    }
+  else
+    {
+      bloc->next->prev = bloc->prev;
+      bloc->prev->next = bloc->next;
+      relocate_some_blocs (bloc->next, bloc->data);
+    }
+
+  relinquish (bloc->size);
+  free (bloc);
+}
+
+static int use_relocatable_buffers;
+
+/* Obtain SIZE bytes of storage from the free pool, or the system,
+   as neccessary.  If relocatable blocs are in use, this means
+   relocating them. */
+
+POINTER 
+r_alloc_sbrk (size)
+     long size;
+{
+  POINTER ptr;
+
+  if (! use_relocatable_buffers)
+    return sbrk (size);
+
+  if (size > 0)
+    {
+      obtain (size);
+      if (first_bloc)
+	{
+	  relocate_some_blocs (first_bloc, first_bloc->data + size);
+	  bzero (virtual_break_value, size);
+	}
+    }
+  else if (size < 0)
+    {
+      if (first_bloc)
+        relocate_some_blocs (first_bloc, first_bloc->data + size);
+      relinquish (- size);
+    }
+
+  ptr = virtual_break_value;
+  virtual_break_value += size;
+  return ptr;
+}
+
+/* Allocate a relocatable bloc of storage of size SIZE.  A pointer to
+   the data is returned in *PTR.  PTR is thus the address of some variable
+   which will use the data area. */
+
+POINTER
+r_alloc (ptr, size)
+     POINTER *ptr;
+     SIZE size;
+{
+  register bloc_ptr new_bloc;
+
+  BLOCK_INPUT;
+  new_bloc = get_bloc (size);
+  new_bloc->variable = ptr;
+  *ptr = new_bloc->data;
+  UNBLOCK_INPUT;
+
+  return *ptr;
+}
+
+/* Free a bloc of relocatable storage whose data is pointed to by PTR. */
+
+void
+r_alloc_free (ptr)
+     register POINTER *ptr;
+{
+  register bloc_ptr dead_bloc;
+
+  BLOCK_INPUT;
+  dead_bloc = find_bloc (ptr);
+  if (dead_bloc == NIL_BLOC)
+    abort ();
+
+  free_bloc (dead_bloc);
+  UNBLOCK_INPUT;
+}
+
+/* Given a pointer at address PTR to relocatable data, resize it
+   to SIZE.  This is done by obtaining a new block and freeing the
+   old, unless SIZE is less than or equal to the current bloc size,
+   in which case nothing happens and the current value is returned.
+
+   The contents of PTR is changed to reflect the new bloc, and this
+   value is returned. */
+
+POINTER
+r_re_alloc (ptr, size)
+     POINTER *ptr;
+     SIZE size;
+{
+  register bloc_ptr old_bloc, new_bloc;
+
+  BLOCK_INPUT;
+  old_bloc = find_bloc (ptr);
+  if (old_bloc == NIL_BLOC)
+    abort ();
+
+  if (size <= old_bloc->size)
+    return *ptr;
+
+  new_bloc = get_bloc (size);
+  new_bloc->variable = ptr;
+  safe_bcopy (old_bloc->data, new_bloc->data, old_bloc->size);
+  *ptr = new_bloc->data;
+
+  free_bloc (old_bloc);
+  UNBLOCK_INPUT;
+
+  return *ptr;
+}
+
+/* The hook `malloc' uses for the function which gets more space
+   from the system.  */
+extern POINTER (*__morecore) ();
+
+/* Intialize various things for memory allocation. */
+
+void
+malloc_init (start, warn_func)
+     POINTER start;
+     void (*warn_func) ();
+{
+  static int malloc_initialized = 0;
+
+  if (start)
+    data_space_start = start;
+
+  if (malloc_initialized)
+    return;
+
+  malloc_initialized = 1;
+  __morecore = r_alloc_sbrk;
+  virtual_break_value = break_value = sbrk (0);
+  page_break_value = (POINTER) ROUNDUP (break_value);
+  bzero (break_value, (page_break_value - break_value));
+  use_relocatable_buffers = 1;
+
+  lim_data = 0;
+  warnlevel = 0;
+  warnfunction = warn_func;
+
+  get_lim_data ();
+}

src/unexhp9k800.c

@@ -0,0 +1,293 @@
+/* Unexec for HP 9000 Series 800 machines.
+   Bob Desinger <hpsemc!bd@hplabs.hp.com>
+
+   Note that the GNU project considers support for HP operation a
+   peripheral activity which should not be allowed to divert effort
+   from development of the GNU system.  Changes in this code will be
+   installed when users send them in, but aside from that we don't
+   plan to think about it, or about whether other Emacs maintenance
+   might break it.
+
+
+  Unexec creates a copy of the old a.out file, and replaces the old data
+  area with the current data area.  When the new file is executed, the
+  process will see the same data structures and data values that the
+  original process had when unexec was called.
+  
+  Unlike other versions of unexec, this one copies symbol table and
+  debug information to the new a.out file.  Thus, the new a.out file
+  may be debugged with symbolic debuggers.
+  
+  If you fix any bugs in this, I'd like to incorporate your fixes.
+  Send them to uunet!hpda!hpsemc!jmorris or jmorris%hpsemc@hplabs.HP.COM.
+  
+  CAVEATS:
+  This routine saves the current value of all static and external
+  variables.  This means that any data structure that needs to be
+  initialized must be explicitly reset.  Variables will not have their
+  expected default values.
+  
+  Unfortunately, the HP-UX signal handler has internal initialization
+  flags which are not explicitly reset.  Thus, for signals to work in
+  conjunction with this routine, the following code must executed when
+  the new process starts up.
+  
+  void _sigreturn();
+  ...
+  sigsetreturn(_sigreturn);
+*/
+
+#include <stdio.h>
+#include <fcntl.h>
+#include <errno.h>
+
+#include <a.out.h>
+
+#define NBPG 2048
+#define roundup(x,n) ( ( (x)+(n-1) ) & ~(n-1) )  /* n is power of 2 */
+#define min(x,y)  ( ((x)<(y))?(x):(y) )
+
+
+/* Create a new a.out file, same as old but with current data space */
+
+unexec(new_name, old_name, new_end_of_text, dummy1, dummy2)
+     char new_name[];		/* name of the new a.out file to be created */
+     char old_name[];		/* name of the old a.out file */
+     char *new_end_of_text;	/* ptr to new edata/etext; NOT USED YET */
+     int dummy1, dummy2;	/* not used by emacs */
+{
+  int old, new;
+  int old_size, new_size;
+  struct header hdr;
+  struct som_exec_auxhdr auxhdr;
+  
+  /* For the greatest flexibility, should create a temporary file in
+     the same directory as the new file.  When everything is complete,
+     rename the temp file to the new name.
+     This way, a program could update its own a.out file even while
+     it is still executing.  If problems occur, everything is still
+     intact.  NOT implemented.  */
+  
+  /* Open the input and output a.out files */
+  old = open(old_name, O_RDONLY);
+  if (old < 0)
+    { perror(old_name); exit(1); }
+  new = open(new_name, O_CREAT|O_RDWR|O_TRUNC, 0777);
+  if (new < 0)
+    { perror(new_name); exit(1); }
+  
+  /* Read the old headers */
+  read_header(old, &hdr, &auxhdr);
+  
+  /* Decide how large the new and old data areas are */
+  old_size = auxhdr.exec_dsize;
+  new_size = sbrk(0) - auxhdr.exec_dmem;
+  
+  /* Copy the old file to the new, up to the data space */
+  lseek(old, 0, 0);
+  copy_file(old, new, auxhdr.exec_dfile);
+  
+  /* Skip the old data segment and write a new one */
+  lseek(old, old_size, 1);
+  save_data_space(new, &hdr, &auxhdr, new_size);
+  
+  /* Copy the rest of the file */
+  copy_rest(old, new);
+  
+  /* Update file pointers since we probably changed size of data area */
+  update_file_ptrs(new, &hdr, &auxhdr, auxhdr.exec_dfile, new_size-old_size);
+  
+  /* Save the modified header */
+  write_header(new, &hdr, &auxhdr);
+  
+  /* Close the binary file */
+  close(old);
+  close(new);
+  exit(0);
+}
+
+/* Save current data space in the file, update header.  */
+
+save_data_space(file, hdr, auxhdr, size)
+     int file;
+     struct header *hdr;
+     struct som_exec_auxhdr *auxhdr;
+     int size;
+{
+  /* Write the entire data space out to the file */
+  if (write(file, auxhdr->exec_dmem, size) != size)
+    { perror("Can't save new data space"); exit(1); }
+  
+  /* Update the header to reflect the new data size */
+  auxhdr->exec_dsize = size;
+  auxhdr->exec_bsize = 0;
+}
+
+/* Update the values of file pointers when something is inserted.  */
+
+update_file_ptrs(file, hdr, auxhdr, location, offset)
+     int file;
+     struct header *hdr;
+     struct som_exec_auxhdr *auxhdr;
+     unsigned int location;
+     int offset;
+{
+  struct subspace_dictionary_record subspace;
+  int i;
+  
+  /* Increase the overall size of the module */
+  hdr->som_length += offset;
+  
+  /* Update the various file pointers in the header */
+#define update(ptr) if (ptr > location) ptr = ptr + offset
+  update(hdr->aux_header_location);
+  update(hdr->space_strings_location);
+  update(hdr->init_array_location);
+  update(hdr->compiler_location);
+  update(hdr->symbol_location);
+  update(hdr->fixup_request_location);
+  update(hdr->symbol_strings_location);
+  update(hdr->unloadable_sp_location);
+  update(auxhdr->exec_tfile);
+  update(auxhdr->exec_dfile);
+  
+  /* Do for each subspace dictionary entry */
+  lseek(file, hdr->subspace_location, 0);
+  for (i = 0; i < hdr->subspace_total; i++)
+    {
+      if (read(file, &subspace, sizeof(subspace)) != sizeof(subspace))
+	{ perror("Can't read subspace record"); exit(1); }
+      
+      /* If subspace has a file location, update it */
+      if (subspace.initialization_length > 0 
+	  && subspace.file_loc_init_value > location)
+	{
+	  subspace.file_loc_init_value += offset;
+	  lseek(file, -sizeof(subspace), 1);
+	  if (write(file, &subspace, sizeof(subspace)) != sizeof(subspace))
+	    { perror("Can't update subspace record"); exit(1); }
+	}
+    } 
+  
+  /* Do for each initialization pointer record */
+  /* (I don't think it applies to executable files, only relocatables) */
+#undef update
+}
+
+/* Read in the header records from an a.out file.  */
+
+read_header(file, hdr, auxhdr)
+     int file;
+     struct header *hdr;
+     struct som_exec_auxhdr *auxhdr;
+{
+  
+  /* Read the header in */
+  lseek(file, 0, 0);
+  if (read(file, hdr, sizeof(*hdr)) != sizeof(*hdr))
+    { perror("Couldn't read header from a.out file"); exit(1); }
+  
+  if (hdr->a_magic != EXEC_MAGIC && hdr->a_magic != SHARE_MAGIC
+      &&  hdr->a_magic != DEMAND_MAGIC)
+    {
+      fprintf(stderr, "a.out file doesn't have legal magic number\n"); 
+      exit(1);  
+    }
+  
+  lseek(file, hdr->aux_header_location, 0);
+  if (read(file, auxhdr, sizeof(*auxhdr)) != sizeof(*auxhdr))
+    {
+      perror("Couldn't read auxiliary header from a.out file");
+      exit(1);
+    }  
+}
+
+/* Write out the header records into an a.out file.  */
+
+write_header(file, hdr, auxhdr)
+     int file;
+     struct header *hdr;
+     struct som_exec_auxhdr *auxhdr;
+{
+  /* Update the checksum */
+  hdr->checksum = calculate_checksum(hdr);
+  
+  /* Write the header back into the a.out file */
+  lseek(file, 0, 0);
+  if (write(file, hdr, sizeof(*hdr)) != sizeof(*hdr))
+    { perror("Couldn't write header to a.out file"); exit(1); }
+  lseek(file, hdr->aux_header_location, 0);
+  if (write(file, auxhdr, sizeof(*auxhdr)) != sizeof(*auxhdr))
+    { perror("Couldn't write auxiliary header to a.out file"); exit(1); }
+}
+
+/* Calculate the checksum of a SOM header record. */
+
+calculate_checksum(hdr)
+     struct header *hdr;
+{
+  int checksum, i, *ptr;
+  
+  checksum = 0;  ptr = (int *) hdr;
+  
+  for (i=0; i<sizeof(*hdr)/sizeof(int)-1; i++)
+    checksum ^= ptr[i];
+  
+  return(checksum);
+}
+
+/* Copy size bytes from the old file to the new one.  */
+
+copy_file(old, new, size)
+     int new, old;
+     int size;
+{
+  int len;
+  int buffer[8196];  /* word aligned will be faster */
+  
+  for (; size > 0; size -= len)
+    {
+      len = min(size, sizeof(buffer));
+      if (read(old, buffer, len) != len)
+	{ perror("Read failure on a.out file"); exit(1); }
+      if (write(new, buffer, len) != len)
+	{ perror("Write failure in a.out file"); exit(1); }
+    }
+}
+
+/* Copy the rest of the file, up to EOF.  */
+
+copy_rest(old, new)
+     int new, old;
+{
+  int buffer[4096];
+  int len;
+  
+  /* Copy bytes until end of file or error */
+  while ( (len = read(old, buffer, sizeof(buffer))) > 0)
+    if (write(new, buffer, len) != len) break;
+  
+  if (len != 0)
+    { perror("Unable to copy the rest of the file"); exit(1); }
+}
+
+#ifdef	DEBUG
+display_header(hdr, auxhdr)
+     struct header *hdr;
+     struct som_exec_auxhdr *auxhdr;
+{
+  /* Display the header information (debug) */
+  printf("\n\nFILE HEADER\n");
+  printf("magic number %d \n", hdr->a_magic); 
+  printf("text loc %.8x   size %d \n", auxhdr->exec_tmem, auxhdr->exec_tsize);
+  printf("data loc %.8x   size %d \n", auxhdr->exec_dmem, auxhdr->exec_dsize);
+  printf("entry     %x \n",   auxhdr->exec_entry);
+  printf("Bss  segment size %u\n", auxhdr->exec_bsize);
+  printf("\n");
+  printf("data file loc %d    size %d\n",
+	 auxhdr->exec_dfile, auxhdr->exec_dsize);
+  printf("som_length %d\n", hdr->som_length);
+  printf("unloadable sploc %d    size %d\n",
+	 hdr->unloadable_sp_location, hdr->unloadable_sp_size);
+}
+#endif /* DEBUG */

src/vms-pp.c

@@ -0,0 +1,242 @@
+/* vms_pp - preprocess emacs files in such a way that they can be
+ *          compiled on VMS without warnings.
+ * Copyright (C) 1986 Free Software Foundation, Inc.
+   
+   This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING.  If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+ *
+ * Usage:
+ *	vms_pp infile outfile
+ * implicit inputs:
+ *	The file "vms_pp.trans" has the names and their translations.
+ * description:
+ *	Vms_pp takes the input file and scans it, replacing the long
+ *	names with shorter names according to the table read in from
+ *	vms_pp.trans. The line is then written to the output file.
+ *
+ *	Additionally, the "#undef foo" construct is replaced with:
+ *		#ifdef foo
+ *		#undef foo
+ *		#endif
+ *
+ *	The construct #if defined(foo) is replaced with
+ *		#ifdef foo
+ *		#define foo_VAL 1
+ *		#else
+ *		#define foo_VAL 0
+ *		#endif
+ *		#define defined(XX) XX_val
+ *		#if defined(foo)
+ *
+ *	This last contruction only works on single line #if's and takes
+ *	advantage of a questionable C pre-processor trick. If there are
+ *	comments within the #if, that contain "defined", then this will
+ *	bomb.
+ */
+#include <stdio.h>
+
+#define Max_table 100
+#define Table_name "vms_pp.trans"
+#define Word_member \
+"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$"
+
+static   FILE *in,*out;			/* read from, write to */
+struct item {				/* symbol table entries */
+  char *name;
+  char *value;
+};
+static struct item name_table[Max_table]; /* symbol table */
+static int defined_defined = 0;		/* small optimization */
+
+main(argc,argv) int argc; char **argv; {
+  char buffer[1024];
+
+  if(argc != 3) {			/* check argument count */
+    fprintf(stderr,"usage: vms_pp infile outfile");
+    exit();
+  }
+  init_table();				/* read in translation table */
+
+/* open input and output files
+ */
+  if((in = fopen(argv[1],"r")) == NULL) {
+    fprintf(stderr,"vms_pp: unable to open file '%s'",argv[1]);
+    exit();
+  }
+  if((out = fopen(argv[2],"w")) == NULL) {
+    fprintf(stderr,"vms_pp: unable to create file '%s'",argv[2]);
+    exit();
+  }
+
+  while(fgets(buffer,1023,in) != NULL) { /* loop through buffer until end */
+    process_line(buffer);		/* process the line */
+    fputs(buffer,out);			/* write out the line */
+  }
+}
+
+/* buy - allocate and copy a string
+ */
+static char *buy(str) char *str; {
+  char *temp;
+
+  if(!(temp = malloc(strlen(str)+1))) {
+    fprintf(stderr,"vms_pp: can't allocate memory");
+    exit();
+  }
+  strcpy(temp,str);
+  return temp;
+}
+
+/* gather_word - return a buffer full of the next word
+ */
+static char *gather_word(ptr,word) char *ptr, *word;{
+  for(; strchr(Word_member,*ptr); ptr++,word++)
+    *word = *ptr;
+  *word = 0;
+  return ptr;
+}
+
+/* skip_white - skip white space
+ */
+static char *skip_white(ptr) char *ptr; {
+  while(*ptr == ' ' || *ptr == '\t')
+    ptr++;
+  return ptr;
+}
+
+/* init_table - initialize translation table.
+ */
+init_table() {
+  char buf[256],*ptr,word[128];
+  FILE *in;
+  int i;
+
+  if((in = fopen(Table_name,"r")) == NULL) { /* open file */
+    fprintf(stderr,"vms_pp: can't open '%s'",Table_name);
+    exit();
+  }
+  for(i = 0; fgets(buf,255,in) != NULL;) { /* loop through lines */
+    ptr = skip_white(buf);
+    if(*ptr == '!')			/* skip comments */
+      continue;
+    ptr = gather_word(ptr,word);	/* get long word */
+    if(*word == 0) {			/* bad entry */
+      fprintf(stderr,"vms_pp: bad input line '%s'\n",buf);
+      continue;
+    }
+    name_table[i].name = buy(word);	/* set up the name */
+    ptr = skip_white(ptr);		/* skip white space */
+    ptr = gather_word(ptr,word);	/* get equivalent name */
+    if(*word == 0) {			/* bad entry */
+      fprintf(stderr,"vms_pp: bad input line '%s'\n",buf);
+      continue;
+    }
+    name_table[i].value = buy(word);	/* and the equivalent name */
+    i++;				/* increment to next position */
+  }
+  for(; i < Max_table; i++)		/* mark rest as unused */
+    name_table[i].name = 0;
+}
+
+/* process_line - do actual line processing
+ */
+process_line(buf) char *buf; {
+  char *in_ptr,*out_ptr;
+  char word[128],*ptr;
+  int len;
+
+  check_pp(buf);			/* check for preprocessor lines */
+
+  for(in_ptr = out_ptr = buf; *in_ptr;) {
+    if(!strchr(Word_member,*in_ptr))	/* non alpha-numeric? just copy */
+      *out_ptr++ = *in_ptr++;
+    else {
+      in_ptr = gather_word(in_ptr,word); /* get the 'word' */
+      if(strlen(word) > 31)		/* length is too long */
+	replace_word(word);		/* replace the word */
+      for(ptr = word; *ptr; ptr++,out_ptr++) /* copy out the word */
+	  *out_ptr = *ptr;
+    }
+  }
+  *out_ptr = 0;
+}
+
+/* check_pp - check for preprocessor lines
+ */
+check_pp(buf) char *buf; {
+  char *ptr,*p;
+  char word[128];
+
+  ptr = skip_white(buf);		/* skip white space */
+  if(*ptr != '#')			/* is this a preprocessor line? */
+    return;				/* no, just return */
+
+  ptr = skip_white(++ptr);		/* skip white */
+  ptr = gather_word(ptr,word);		/* get command word */
+  if(!strcmp("undef",word)) {		/* undef? */
+    ptr = skip_white(ptr);
+    ptr = gather_word(ptr,word);	/* get the symbol to undef */
+    fprintf(out,"#ifdef %s\n",word);
+    fputs(buf,out);
+    strcpy(buf,"#endif");
+    return;
+  }
+  if(!strcmp("if",word)) {		/* check for if */
+    for(;;) {
+      ptr = strchr(ptr,'d');		/* look for d in defined */
+      if(!ptr)				/* are we done? */
+	return;
+      if(strchr(Word_member,*(ptr-1))){	/* at beginning of word? */
+	ptr++; continue;		/* no, continue looking */
+      }
+      ptr = gather_word(ptr,word);	/* get the word */
+      if(strcmp(word,"defined"))	/* skip if not defined */
+	continue;
+      ptr = skip_white(ptr);		/* skip white */
+      if(*ptr != '(')			/* look for open paren */
+	continue;			/* error, continue */
+      ptr++;				/* skip paren */
+      ptr = skip_white(ptr);		/* more white skipping */
+      ptr = gather_word(ptr,word);	/* get the thing to test */
+      if(!*word)			/* null word is bad */
+	continue;
+      fprintf(out,"#ifdef %s\n",word);	/* generate the code */
+      fprintf(out,"#define %s_VAL 1\n",word);
+      fprintf(out,"#else\n");
+      fprintf(out,"#define %s_VAL 0\n",word);
+      fprintf(out,"#endif\n");
+      if(!defined_defined) {
+	fprintf(out,"#define defined(XXX) XXX/**/_VAL\n");
+	defined_defined = 1;
+      }
+    }
+  }
+}
+
+/* replace_word - look the word up in the table, and replace it
+ *		  if a match is found.
+ */
+replace_word(word) char *word; {
+  int i;
+
+  for(i = 0; i < Max_table && name_table[i].name; i++)
+    if(!strcmp(word,name_table[i].name)) {
+      strcpy(word,name_table[i].value);
+      return;
+    }
+  fprintf(stderr,"couldn't find '%s'\n",word);
+}

src/vmsproc.c

@@ -0,0 +1,786 @@
+/* Interfaces to subprocesses on VMS.
+   Copyright (C) 1988 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING.  If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+
+/*
+    Event flag and `select' emulation
+
+    0 is never used
+    1 is the terminal
+    23 is the timer event flag
+    24-31 are reserved by VMS
+*/
+#include	<ssdef.h>
+#include	<iodef.h>
+#include	<dvidef.h>
+#include	<clidef.h>
+#include	"vmsproc.h"
+
+#define		KEYBOARD_EVENT_FLAG		1
+#define		TIMER_EVENT_FLAG		23
+
+static VMS_PROC_STUFF	procList[MAX_EVENT_FLAGS+1];
+
+get_kbd_event_flag ()
+{
+  /*
+    Return the first event flag for keyboard input.
+    */
+  VMS_PROC_STUFF	*vs = &procList[KEYBOARD_EVENT_FLAG];
+
+  vs->busy = 1;
+  vs->pid = 0;
+  return (vs->eventFlag);
+}
+
+get_timer_event_flag ()
+{
+  /*
+    Return the last event flag for use by timeouts
+    */
+  VMS_PROC_STUFF	*vs = &procList[TIMER_EVENT_FLAG];
+
+  vs->busy = 1;
+  vs->pid = 0;
+  return (vs->eventFlag);
+}
+
+VMS_PROC_STUFF *
+get_vms_process_stuff ()
+{
+  /*
+    Return a process_stuff structure
+    
+    We use 1-23 as our event flags to simplify implementing
+    a VMS `select' call. 
+    */
+  int i;
+  VMS_PROC_STUFF *vs;
+
+  for (i=1, vs = procList; i<MAX_EVENT_FLAGS; i++, vs++)
+    {
+      if (!vs->busy)
+	{
+	  vs->busy = 1;
+	  vs->inputChan = 0;
+	  vs->pid = 0;
+	  sys$clref (vs->eventFlag);
+	  return (vs);
+	}
+    }
+  return ((VMS_PROC_STUFF *)0);
+}
+
+give_back_vms_process_stuff (vs)
+     VMS_PROC_STUFF *vs;
+{
+  /*
+    Return an event flag to our pool
+    */
+  vs->busy = 0;
+  vs->inputChan = 0;
+  vs->pid = 0;
+}
+
+VMS_PROC_STUFF *
+get_vms_process_pointer (pid)
+     int pid;
+{
+  /*
+    Given a pid, return the VMS_STUFF pointer
+    */
+  int			i;
+  VMS_PROC_STUFF	*vs;
+
+  /* Don't search the last one */
+  for (i=0, vs=procList; i<MAX_EVENT_FLAGS; i++, vs++)
+    {
+      if (vs->busy && vs->pid == pid)
+	return (vs);
+    }
+  return ((VMS_PROC_STUFF *)0);
+}
+
+start_vms_process_read (vs)
+     VMS_PROC_STUFF *vs;
+{
+  /*
+    Start an asynchronous  read on a VMS process
+    We will catch up with the output sooner or later
+    */
+  int			status;
+  int			ProcAst ();
+
+  status = sys$qio (vs->eventFlag, vs->outputChan, IO$_READVBLK,
+		   vs->iosb, 0, vs,
+		   vs->inputBuffer, sizeof (vs->inputBuffer), 0, 0, 0, 0);
+  if (status != SS$_NORMAL)
+    return (0);
+  else
+    return (1);
+}
+
+extern int	waiting_for_ast;		/* in sysdep.c */
+extern int	timer_ef;
+extern int	input_ef;
+
+select (nDesc, rdsc, wdsc, edsc, timeOut)
+     int nDesc;
+     int *rdsc;
+     int *wdsc;
+     int *edsc;
+     int *timeOut;
+{
+  /* Emulate a select call
+     
+     We know that we only use event flags 1-23
+     
+     timeout == 100000 & bit 0 set means wait on keyboard input until
+     something shows up.  If timeout == 0, we just read the event
+     flags and return what we find.  */
+
+  int nfds = 0;
+  int status;
+  int time[2];
+  int delta = -10000000;
+  int zero = 0;
+  int timeout = *timeOut;
+  unsigned long	mask, readMask, waitMask;
+
+  if (rdsc)
+    readMask = *rdsc << 1;	/* Unix mask is shifted over 1 */
+  else
+    readMask = 0;		/* Must be a wait call */
+
+  sys$clref (KEYBOARD_EVENT_FLAG);
+  sys$setast (0);		/* Block interrupts */
+  sys$readef (KEYBOARD_EVENT_FLAG, &mask); /* See what is set */
+  mask &= readMask;		/* Just examine what we need */
+  if (mask == 0)
+    {		/* Nothing set, we must wait */
+      if (timeout != 0)
+	{	/* Not just inspecting... */
+	  if (!(timeout == 100000 &&
+		readMask == (1 << KEYBOARD_EVENT_FLAG)))
+	    {
+	      lib$emul (&timeout, &delta, &zero, time);
+	      sys$setimr (TIMER_EVENT_FLAG, time, 0, 1);
+	      waitMask = readMask | (1 << TIMER_EVENT_FLAG);
+	    }
+	  else
+	    waitMask = readMask;
+	  if (waitMask & (1 << KEYBOARD_EVENT_FLAG))
+	    {
+	      sys$clref (KEYBOARD_EVENT_FLAG);
+	      waiting_for_ast = 1; /* Only if reading from 0 */
+	    }
+	  sys$setast (1);
+	  sys$wflor (KEYBOARD_EVENT_FLAG, waitMask);
+	  sys$cantim (1, 0);
+	  sys$readef (KEYBOARD_EVENT_FLAG, &mask);
+	  if (readMask & (1 << KEYBOARD_EVENT_FLAG))
+	    waiting_for_ast = 0;
+	}
+    }
+  sys$setast (1);
+
+  /*
+    Count number of descriptors that are ready
+    */
+  mask &= readMask;
+  if (rdsc)
+    *rdsc = (mask >> 1);	/* Back to Unix format */
+  for (nfds = 0; mask; mask >>= 1)
+    {
+      if (mask & 1)
+	nfds++;
+    }
+  return (nfds);
+}
+
+#define	MAX_BUFF	1024
+
+write_to_vms_process (vs, buf, len)
+     VMS_PROC_STUFF *vs;
+     char *buf;
+     int len;
+{
+  /*
+    Write something to a VMS process.
+    
+    We have to map newlines to carriage returns for VMS.
+    */
+  char		ourBuff[MAX_BUFF];
+  short		iosb[4];
+  int			status;
+  int			in, out;
+
+  while (len > 0)
+    {
+      out = map_nl_to_cr (buf, ourBuff, len, MAX_BUFF);
+      status = sys$qiow (0, vs->inputChan, IO$_WRITEVBLK|IO$M_NOFORMAT,
+			iosb, 0, 0, ourBuff, out, 0, 0, 0, 0);
+      if (status != SS$_NORMAL || (status = iosb[0]) != SS$_NORMAL)
+	{
+	  error ("Could not write to subprocess: %x", status);
+	  return (0);
+	}
+      len =- out;
+    }
+  return (1);
+}
+
+static
+map_nl_to_cr (in, out, maxIn, maxOut)
+     char *in;
+     char *out;
+     int maxIn;
+     int maxOut;
+{
+  /*
+    Copy `in' to `out' remapping `\n' to `\r'
+    */
+  int			c;
+  int			o;
+
+  for (o=0; maxIn-- > 0 && o < maxOut; o++)
+    {
+      c = *in++;
+      *out++ = (c == '\n') ? '\r' : c;
+    }
+  return (o);
+}
+
+clean_vms_buffer (buf, len)
+     char *buf;
+     int len;
+{
+  /*
+    Sanitize output from a VMS subprocess
+    Strip CR's and NULLs
+    */
+  char		*oBuf = buf;
+  char		c;
+  int			l = 0;
+
+  while (len-- > 0)
+    {
+      c = *buf++;
+      if (c == '\r' || c == '\0')
+	;
+      else
+	{
+	  *oBuf++ = c;
+	  l++;
+	}
+    }
+  return (l);
+}
+
+/*
+    For the CMU PTY driver
+*/
+#define		PTYNAME		"PYA0:"
+
+get_pty_channel (inDevName, outDevName, inChannel, outChannel)
+     char *inDevName;
+     char *outDevName;
+     int *inChannel;
+     int *outChannel;
+{
+  int			PartnerUnitNumber;
+  int			status;
+  struct {
+    int	l;
+    char	*a;
+  } d;
+  struct {
+    short	BufLen;
+    short	ItemCode;
+    int	*BufAddress;
+    int	*ItemLength;
+  } g[2];
+    
+  d.l = strlen (PTYNAME);
+  d.a = PTYNAME;
+  *inChannel = 0;		/* Should be `short' on VMS */
+  *outChannel = 0;
+  *inDevName = *outDevName = '\0';
+  status  = sys$assign (&d, inChannel, 0, 0);
+  if (status == SS$_NORMAL)
+    {
+      *outChannel = *inChannel;
+      g[0].BufLen = sizeof (PartnerUnitNumber);
+      g[0].ItemCode = DVI$_UNIT;
+      g[0].BufAddress = &PartnerUnitNumber;
+      g[0].ItemLength = (int *)0;
+      g[1].BufLen = g[1].ItemCode = 0;
+      status = sys$getdviw (0, *inChannel, 0, &g, 0, 0, 0, 0);
+      if (status == SS$_NORMAL)
+	{
+	  sprintf (inDevName, "_TPA%d:", PartnerUnitNumber);
+	  strcpy (outDevName, inDevName);
+	}
+    }
+  return (status);
+}
+
+VMSgetwd (buf)
+     char *buf;
+{
+  /*
+    Return the current directory
+    */
+  char curdir[256];
+  char *getenv ();
+  char *s;
+  short len;
+  int status;
+  struct
+    {
+      int	l;
+      char	*a;
+    } d;
+
+  s = getenv ("SYS$DISK");
+  if (s)
+    strcpy (buf, s);
+  else
+    *buf = '\0';
+
+  d.l = 255;
+  d.a = curdir;
+  status = sys$setddir (0, &len, &d);
+  if (status & 1)
+    {
+      curdir[len] = '\0';
+      strcat (buf, curdir);
+    }
+}
+
+static
+call_process_ast (vs)
+     VMS_PROC_STUFF *vs;
+{
+  sys$setef (vs->eventFlag);
+}
+
+void
+child_setup (in, out, err, new_argv, env)
+     int in, out, err;
+     register char **new_argv;
+     char **env;
+{
+  /* ??? I suspect that maybe this shouldn't be done on VMS.  */
+#ifdef subprocesses
+  /* Close Emacs's descriptors that this process should not have.  */
+  close_process_descs ();
+#endif
+
+  if (XTYPE (current_buffer->directory) == Lisp_String)
+    chdir (XSTRING (current_buffer->directory)->data);
+}
+
+DEFUN ("call-process", Fcall_process, Scall_process, 1, MANY, 0,
+  "Call PROGRAM synchronously in a separate process.\n\
+Program's input comes from file INFILE (nil means null device, `NLA0:').\n\
+Insert output in BUFFER before point; t means current buffer;\n\
+ nil for BUFFER means discard it; 0 means discard and don't wait.\n\
+Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.\n\
+Remaining arguments are strings passed as command arguments to PROGRAM.\n\
+This function waits for PROGRAM to terminate, unless BUFFER is 0;\n\
+if you quit, the process is killed.")
+  (nargs, args)
+     int nargs;
+     register Lisp_Object *args;
+{
+  Lisp_Object display, buffer, path;
+  char oldDir[512];
+  int inchannel, outchannel;
+  int len;
+  int call_process_ast ();
+  struct
+    {
+      int l;
+      char *a;
+    } dcmd, din, dout;
+  char inDevName[65];
+  char outDevName[65];
+  short iosb[4];
+  int status;
+  int SpawnFlags = CLI$M_NOWAIT;
+  VMS_PROC_STUFF *vs;
+  VMS_PROC_STUFF *get_vms_process_stuff ();
+  int fd[2];
+  int filefd;
+  register int pid;
+  char buf[1024];
+  int count = specpdl_ptr - specpdl;
+  register unsigned char **new_argv;
+  struct buffer *old = current_buffer;
+
+  CHECK_STRING (args[0], 0);
+
+  if (nargs <= 1 || NULL (args[1]))
+    args[1] = build_string ("NLA0:");
+  else
+    args[1] = Fexpand_file_name (args[1], current_buffer->directory);
+
+  CHECK_STRING (args[1], 1);
+
+  {
+    register Lisp_Object tem;
+    buffer = tem = args[2];
+    if (nargs <= 2)
+      buffer = Qnil;
+    else if (!(EQ (tem, Qnil) || EQ (tem, Qt)
+	       || XFASTINT (tem) == 0))
+      {
+	buffer = Fget_buffer (tem);
+	CHECK_BUFFER (buffer, 2);
+      }
+  }
+
+  display = nargs >= 3 ? args[3] : Qnil;
+
+  {
+    /*
+	if (args[0] == "*dcl*" then we need to skip pas the "-c",
+	else args[0] is the program to run.
+    */
+    register int i;
+    int arg0;
+    int firstArg;
+
+    if (strcmp (XSTRING (args[0])->data, "*dcl*") == 0)
+      {
+	arg0 = 5;
+	firstArg = 6;
+      }
+    else
+      {
+	arg0 = 0;
+	firstArg = 4;
+      }
+    len = XSTRING (args[arg0])->size + 1;
+    for (i = firstArg; i < nargs; i++)
+      {
+	CHECK_STRING (args[i], i);
+	len += XSTRING (args[i])->size + 1;
+      }
+    new_argv = alloca (len);
+    strcpy (new_argv, XSTRING (args[arg0])->data);
+    for (i = firstArg; i < nargs; i++)
+      {
+	strcat (new_argv, " ");
+	strcat (new_argv, XSTRING (args[i])->data);
+      }
+    dcmd.l = len-1;
+    dcmd.a = new_argv;
+    
+    status = get_pty_channel (inDevName, outDevName, &inchannel, &outchannel);
+    if (!(status & 1))
+      error ("Error getting PTY channel: %x", status);
+    if (XTYPE (buffer) == Lisp_Int)
+      {
+	dout.l = strlen ("NLA0:");
+	dout.a = "NLA0:";
+      }
+    else
+      {
+	dout.l = strlen (outDevName);
+	dout.a = outDevName;
+      }
+
+    vs = get_vms_process_stuff ();
+    if (!vs)
+      {
+	sys$dassgn (inchannel);
+	sys$dassgn (outchannel);
+	error ("Too many VMS processes");
+      }
+    vs->inputChan = inchannel;
+    vs->outputChan = outchannel;
+  }
+
+  filefd = open (XSTRING (args[1])->data, O_RDONLY, 0);
+  if (filefd < 0)
+    {
+      sys$dassgn (inchannel);
+      sys$dassgn (outchannel);
+      give_back_vms_process_stuff (vs);
+      report_file_error ("Opening process input file", Fcons (args[1], Qnil));
+    }
+  else
+    close (filefd);
+
+  din.l = XSTRING (args[1])->size;
+  din.a = XSTRING (args[1])->data;
+
+  /*
+      Start a read on the process channel
+  */
+  if (XTYPE (buffer) != Lisp_Int)
+    {
+      start_vms_process_read (vs);
+      SpawnFlags = CLI$M_NOWAIT;
+    }
+  else
+    SpawnFlags = 0;
+
+  /*
+      On VMS we need to change the current directory
+      of the parent process before forking so that
+      the child inherit that directory.  We remember
+      where we were before changing.
+  */
+  VMSgetwd (oldDir);
+  child_setup (0, 0, 0, 0, 0);
+  status = lib$spawn (&dcmd, &din, &dout, &SpawnFlags, 0, &vs->pid,
+	      &vs->exitStatus, 0, call_process_ast, vs);
+  chdir (oldDir);
+
+  if (status != SS$_NORMAL)
+    {
+      sys$dassgn (inchannel);
+      sys$dassgn (outchannel);
+      give_back_vms_process_stuff (vs);
+      error ("Error calling LIB$SPAWN: %x", status);
+    }
+  pid = vs->pid;
+
+  if (XTYPE (buffer) == Lisp_Int)
+    {
+#ifndef subprocesses
+      wait_without_blocking ();
+#endif subprocesses
+      return Qnil;
+    }
+
+  record_unwind_protect (call_process_cleanup,
+			 Fcons (make_number (fd[0]), make_number (pid)));
+
+
+  if (XTYPE (buffer) == Lisp_Buffer)
+    Fset_buffer (buffer);
+
+  immediate_quit = 1;
+  QUIT;
+
+  while (1)
+    {
+      sys$waitfr (vs->eventFlag);
+      if (vs->iosb[0] & 1)
+	{
+	  immediate_quit = 0;
+	  if (!NULL (buffer))
+	    {
+	      vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]);
+	      InsCStr (vs->inputBuffer, vs->iosb[1]);
+	    }
+	  if (!NULL (display) && INTERACTIVE)
+	  redisplay_preserve_echo_area ();
+	  immediate_quit = 1;
+	  QUIT;
+	  if (!start_vms_process_read (vs))
+	    break;		/* The other side went away */
+	}
+      else
+	break;
+    }
+    sys$dassgn (inchannel);
+    sys$dassgn (outchannel);
+    give_back_vms_process_stuff (vs);
+
+  /* Wait for it to terminate, unless it already has.  */
+  wait_for_termination (pid);
+
+  immediate_quit = 0;
+
+  set_current_buffer (old);
+
+  unbind_to (count);
+
+  return Qnil;
+}
+
+create_process (process, new_argv)
+     Lisp_Object process;
+     char *new_argv;
+{
+  int pid, inchannel, outchannel, forkin, forkout;
+  char old_dir[512];
+  char in_dev_name[65];
+  char out_dev_name[65];
+  short iosb[4];
+  int status;
+  int spawn_flags = CLI$M_NOWAIT;
+  int child_sig ();
+  struct {
+    int l;
+    char *a;
+  } din, dout, dprompt, dcmd;
+  VMS_PROC_STUFF *vs;
+  VMS_PROC_STUFF *get_vms_process_stuff ();
+    
+  status = get_pty_channel (in_dev_name, out_dev_name, &inchannel, &outchannel);
+  if (!(status & 1))
+    {
+      remove_process (process);
+      error ("Error getting PTY channel: %x", status);
+    }
+  dout.l = strlen (out_dev_name);
+  dout.a = out_dev_name;
+  dprompt.l = strlen (DCL_PROMPT);
+  dprompt.a = DCL_PROMPT;
+
+  if (strcmp (new_argv, "*dcl*") == 0)
+    {
+      din.l = strlen (in_dev_name);
+      din.a = in_dev_name;
+      dcmd.l = 0;
+      dcmd.a = (char *)0;
+    }
+  else
+    {
+      din.l = strlen ("NLA0:");
+      din.a = "NLA0:";
+      dcmd.l = strlen (new_argv);
+      dcmd.a = new_argv;
+    }
+
+  /* Delay interrupts until we have a chance to store
+     the new fork's pid in its process structure */
+  sys$setast (0);
+
+  vs = get_vms_process_stuff ();
+  if (vs == 0)
+    {
+      sys$setast (1);
+      remove_process (process);
+      error ("Too many VMS processes");
+    }
+  vs->inputChan = inchannel;
+  vs->outputChan = outchannel;
+
+  /* Start a read on the process channel */
+  start_vms_process_read (vs);
+
+  /* Switch current directory so that the child inherits it. */
+  VMSgetwd (old_dir);
+  child_setup (0, 0, 0, 0, 0);
+
+  status = lib$spawn (&dcmd, &din, &dout, &spawn_flags, 0, &vs->pid,
+		      &vs->exitStatus, 0, child_sig, vs, &dprompt);
+  chdir (old_dir);
+
+  if (status != SS$_NORMAL)
+    {
+      sys$setast (1);
+      remove_process (process);
+      error ("Error calling LIB$SPAWN: %x", status);
+    }
+  vs->pid &= 0xffff;		/* It needs to fit in a FASTINT,
+				   we don't need the rest of the bits */
+  pid = vs->pid;
+
+  /*
+    ON VMS process->infd holds the (event flag-1)
+    that we use for doing I/O on that process.
+    `input_wait_mask' is the cluster of event flags
+    we can wait on.
+    
+    Event flags returned start at 1 for the keyboard.
+    Since Unix expects descriptor 0 for the keyboard,
+    we substract one from the event flag.
+    */
+  inchannel = vs->eventFlag-1;
+
+  /* Record this as an active process, with its channels.
+     As a result, child_setup will close Emacs's side of the pipes.  */
+  chan_process[inchannel] = process;
+  XFASTINT (XPROCESS (process)->infd) = inchannel;
+  XFASTINT (XPROCESS (process)->outfd) = outchannel;
+  XFASTINT (XPROCESS (process)->flags) = RUNNING;
+
+  /* Delay interrupts until we have a chance to store
+     the new fork's pid in its process structure */
+
+#define	NO_ECHO		"set term/noecho\r"
+  sys$setast (0);
+  /*
+    Send a command to the process to not echo input
+    
+    The CMU PTY driver does not support SETMODEs.
+    */
+  write_to_vms_process (vs, NO_ECHO, strlen (NO_ECHO));
+
+  XFASTINT (XPROCESS (process)->pid) = pid;
+  sys$setast (1);
+}
+
+child_sig (vs)
+     VMS_PROC_STUFF *vs;
+{
+  register int pid;
+  Lisp_Object tail, proc;
+  register struct Lisp_Process *p;
+  int old_errno = errno;
+
+  pid = vs->pid;
+  sys$setef (vs->eventFlag);
+
+  for (tail = Vprocess_alist; XSYMBOL (tail) != XSYMBOL (Qnil); tail = XCONS (tail)->cdr)
+    {
+      proc = XCONS (XCONS (tail)->car)->cdr;
+      p = XPROCESS (proc);
+      if (EQ (p->childp, Qt) && XFASTINT (p->pid) == pid)
+	break;
+    }
+
+  if (XSYMBOL (tail) == XSYMBOL (Qnil))
+    return;
+
+  child_changed++;
+  XFASTINT (p->flags) = EXITED | CHANGED;
+  /* Truncate the exit status to 24 bits so that it fits in a FASTINT */
+  XFASTINT (p->reason) = (vs->exitStatus) & 0xffffff;
+}
+
+syms_of_vmsproc ()
+{
+  defsubr (&Scall_process);
+}
+
+init_vmsproc ()
+{
+  char *malloc ();
+  int i;
+  VMS_PROC_STUFF *vs;
+
+  for (vs=procList, i=0; i<MAX_EVENT_FLAGS+1; i++, vs++)
+    {
+      vs->busy = 0;
+      vs->eventFlag = i;
+      sys$clref (i);
+      vs->inputChan = 0;
+      vs->pid = 0;
+    }
+  procList[0].busy = 1;		/* Zero is reserved */
+}

src/xmenu.c

@@ -0,0 +1,378 @@
+/* X Communication module for terminals which understand the X protocol.
+   Copyright (C) 1986, 1988 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING.  If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+/* X pop-up deck-of-cards menu facility for gnuemacs.
+ *
+ * Written by Jon Arnold and Roman Budzianowski
+ * Mods and rewrite by Robert Krawitz
+ *
+ */
+
+/* $Source: /u2/third_party/gnuemacs.chow/src/RCS/xmenu.c,v $
+ * $Author: rlk $
+ * $Locker:  $
+ * $Header: xmenu.c,v 1.6 86/08/26 17:23:26 rlk Exp $
+ *
+ */
+
+#ifndef lint
+static char *rcsid_GXMenu_c = "$Header: xmenu.c,v 1.6 86/08/26 17:23:26 rlk Exp $";
+#endif	lint
+#ifdef XDEBUG
+#include <stdio.h>
+#endif
+
+/* On 4.3 this loses if it comes after xterm.h.  */
+#include <signal.h>
+#include "config.h"
+#include "lisp.h"
+#include "screen.h"
+#include "window.h"
+
+/* This may include sys/types.h, and that somehow loses
+   if this is not done before the other system files.  */
+#include "xterm.h"
+
+/* Load sys/types.h if not already loaded.
+   In some systems loading it twice is suicidal.  */
+#ifndef makedev
+#include <sys/types.h>
+#endif
+
+#include "dispextern.h"
+
+#ifdef HAVE_X11
+#include "../oldXMenu/XMenu.h"
+#else
+#include <X/XMenu.h>
+#endif
+
+#define min(x,y) (((x) < (y)) ? (x) : (y))
+#define max(x,y) (((x) > (y)) ? (x) : (y))
+
+#define NUL 0
+
+#ifndef TRUE
+#define TRUE 1
+#define FALSE 0
+#endif TRUE
+
+#ifdef HAVE_X11
+extern Display *x_current_display;
+#else
+#define	ButtonReleaseMask ButtonReleased
+#endif /* not HAVE_X11 */
+
+Lisp_Object xmenu_show ();
+extern int x_error_handler ();
+
+/*************************************************************/
+
+#if 0
+/* Ignoring the args is easiest.  */
+xmenu_quit ()
+{
+  error ("Unknown XMenu error");
+}
+#endif
+
+DEFUN ("x-popup-menu",Fx_popup_menu, Sx_popup_menu, 1, 2, 0,
+  "Pop up a deck-of-cards menu and return user's selection.\n\
+ARG is a position specification: a list ((XOFFSET YOFFSET) WINDOW)\n\
+where XOFFSET and YOFFSET are positions in characters from the top left\n\
+corner of WINDOW's screen.  A mouse-event list will serve for this.\n\
+This controls the position of the center of the first line\n\
+in the first pane of the menu, not the top left of the menu as a whole.\n\
+\n\
+MENU is a specifier for a menu.  It is a list of the form\n\
+\(TITLE PANE1 PANE2...), and each pane is a list of form\n\
+\(TITLE (LINE ITEM)...).  Each line should be a string, and item should\n\
+be the return value for that line (i.e. if it is selected.")
+       (arg, menu)
+     Lisp_Object arg, menu;
+{
+  int number_of_panes;
+  Lisp_Object XMenu_return;
+  int XMenu_xpos, XMenu_ypos;
+  char **menus;
+  char ***names;
+  Lisp_Object **obj_list;
+  int *items;
+  char *title;
+  char *error_name;
+  Lisp_Object ltitle, selection;
+  int i, j;
+  SCREEN_PTR s;
+  Lisp_Object x, y, window;
+
+  window = Fcar (Fcdr (arg));
+  x = Fcar (Fcar (arg));
+  y = Fcar (Fcdr (Fcar (arg)));
+  CHECK_WINDOW (window, 0);
+  CHECK_NUMBER (x, 0);
+  CHECK_NUMBER (y, 0);
+  s = XSCREEN (WINDOW_SCREEN (XWINDOW (window)));
+
+  XMenu_xpos = FONT_WIDTH (s->display.x->font) * XINT (x);
+  XMenu_ypos = FONT_HEIGHT (s->display.x->font) * XINT (y);
+  XMenu_xpos += s->display.x->left_pos;
+  XMenu_ypos += s->display.x->top_pos;
+
+  ltitle = Fcar (menu);
+  CHECK_STRING (ltitle, 1);
+  title = (char *) XSTRING (ltitle)->data;
+  number_of_panes=list_of_panes (&obj_list, &menus, &names, &items, Fcdr (menu));
+#ifdef XDEBUG
+  fprintf (stderr, "Panes= %d\n", number_of_panes);
+  for (i=0; i < number_of_panes; i++)
+    {
+      fprintf (stderr, "Pane %d lines %d title %s\n", i, items[i], menus[i]);
+      for (j=0; j < items[i]; j++)
+	{
+	  fprintf (stderr, "    Item %d %s\n", j, names[i][j]);
+	}
+    }
+#endif
+  BLOCK_INPUT;
+  selection = xmenu_show (ROOT_WINDOW, XMenu_xpos, XMenu_ypos, names, menus,
+			  items, number_of_panes, obj_list, title, &error_name);
+  UNBLOCK_INPUT;
+  /** fprintf (stderr, "selection = %x\n", selection);  **/
+  if (selection != NUL)
+    {				/* selected something */
+      XMenu_return = selection;
+    }
+  else
+    {				/* nothing selected */
+      XMenu_return = Qnil;
+    }
+  /* now free up the strings */
+  for (i=0; i < number_of_panes; i++)
+    {
+      free (names[i]);
+      free (obj_list[i]);
+    }
+  free (menus);
+  free (obj_list);
+  free (names);
+  free (items);
+  /*   free (title); */
+  if (error_name) error (error_name);
+  return XMenu_return;
+}
+
+struct indices {
+  int pane;
+  int line;
+};
+
+Lisp_Object
+xmenu_show (parent, startx, starty, line_list, pane_list, line_cnt,
+		      pane_cnt, item_list, title, error)
+     Window parent;		
+     int startx, starty;	/* upper left corner position BROKEN */
+     char **line_list[];   	/* list of strings for items */
+     char *pane_list[];		/* list of pane titles */
+     char *title;
+     int pane_cnt;		/* total number of panes */
+     Lisp_Object *item_list[];	/* All items */
+     int line_cnt[];		/* Lines in each pane */
+     char **error;		/* Error returned */
+{
+  XMenu *GXMenu;
+  int last, panes, selidx, lpane, status;
+  int lines, sofar;
+  Lisp_Object entry;
+  /* struct indices *datap, *datap_save; */
+  char *datap;
+  int ulx, uly, width, height;
+  int dispwidth, dispheight;
+  
+  *error = (char *) 0;		/* Initialize error pointer to null */
+  GXMenu = XMenuCreate (XDISPLAY parent, "emacs");
+  if (GXMenu == NUL)
+    {
+      *error = "Can't create menu";
+      return (0);
+    }
+  
+  for (panes=0, lines=0; panes < pane_cnt; lines += line_cnt[panes], panes++)
+    ;
+  /* datap = (struct indices *) xmalloc (lines * sizeof (struct indices)); */
+  /*datap = (char *) xmalloc (lines * sizeof (char));
+    datap_save = datap;*/
+  
+  for (panes = 0, sofar=0;panes < pane_cnt;sofar +=line_cnt[panes], panes++)
+    {
+      /* create all the necessary panes */
+      lpane = XMenuAddPane (XDISPLAY GXMenu, pane_list[panes], TRUE);
+      if (lpane == XM_FAILURE)
+	{
+	  XMenuDestroy (XDISPLAY GXMenu);
+	  *error = "Can't create pane";
+	  return (0);
+	}
+      for (selidx = 0; selidx < line_cnt[panes] ; selidx++)
+	{
+	  /* add the selection stuff to the menus */
+	  /* datap[selidx+sofar].pane = panes;
+	     datap[selidx+sofar].line = selidx; */
+	  if (XMenuAddSelection (XDISPLAY GXMenu, lpane, 0,
+				 line_list[panes][selidx], TRUE)
+	      == XM_FAILURE)
+	    {
+	      XMenuDestroy (XDISPLAY GXMenu);
+	      /* free (datap); */
+	      *error = "Can't add selection to menu";
+	      /* error ("Can't add selection to menu"); */
+	      return (0);
+	    }
+	}
+    }
+  /* all set and ready to fly */
+  XMenuRecompute (XDISPLAY GXMenu);
+  dispwidth = DisplayWidth (x_current_display, XDefaultScreen (x_current_display));
+  dispheight = DisplayHeight (x_current_display, XDefaultScreen (x_current_display));
+  startx = min (startx, dispwidth);
+  starty = min (starty, dispheight);
+  startx = max (startx, 1);
+  starty = max (starty, 1);
+  XMenuLocate (XDISPLAY GXMenu, 0, 0, startx, starty,
+	       &ulx, &uly, &width, &height);
+  if (ulx+width > dispwidth)
+    {
+      startx -= (ulx + width) - dispwidth;
+      ulx = dispwidth - width;
+    }
+  if (uly+height > dispheight)
+    {
+      starty -= (uly + height) - dispheight;
+      uly = dispheight - height;
+    }
+  if (ulx < 0) startx -= ulx;
+  if (uly < 0) starty -= uly;
+    
+  XMenuSetFreeze (GXMenu, TRUE);
+  panes = selidx = 0;
+  
+  status = XMenuActivate (XDISPLAY GXMenu, &panes, &selidx,
+			  startx, starty, ButtonReleaseMask, &datap);
+  switch (status)
+    {
+    case XM_SUCCESS:
+#ifdef XDEBUG
+      fprintf (stderr, "pane= %d line = %d\n", panes, selidx);
+#endif
+      entry = item_list[panes][selidx];
+      break;
+    case XM_FAILURE:
+      /*free (datap_save); */
+      XMenuDestroy (XDISPLAY GXMenu);
+      *error = "Can't activate menu";
+      /* error ("Can't activate menu"); */
+    case XM_IA_SELECT:
+    case XM_NO_SELECT:
+      entry = Qnil;
+      break;
+    }
+  XMenuDestroy (XDISPLAY GXMenu);
+  /*free (datap_save);*/
+  return (entry);
+}
+
+syms_of_xmenu ()
+{
+  defsubr (&Sx_popup_menu);
+}
+
+list_of_panes (vector, panes, names, items, menu)
+     Lisp_Object ***vector;	/* RETURN all menu objects */
+     char ***panes;		/* RETURN pane names */
+     char ****names;		/* RETURN all line names */
+     int **items;		/* RETURN number of items per pane */
+     Lisp_Object menu;
+{
+  Lisp_Object tail, item, item1;
+  int i;
+  
+  if (XTYPE (menu) != Lisp_Cons) menu = wrong_type_argument (Qlistp, menu);
+
+  i= XFASTINT (Flength (menu, 1));
+
+  *vector = (Lisp_Object **) xmalloc (i * sizeof (Lisp_Object *));
+  *panes = (char **) xmalloc (i * sizeof (char *));
+  *items = (int *) xmalloc (i * sizeof (int));
+  *names = (char ***) xmalloc (i * sizeof (char **));
+
+  for (i=0, tail = menu; !NULL (tail); tail = Fcdr (tail), i++)
+    {
+       item = Fcdr (Fcar (tail));
+       if (XTYPE (item) != Lisp_Cons) (void) wrong_type_argument (Qlistp, item);
+#ifdef XDEBUG
+       fprintf (stderr, "list_of_panes check tail, i=%d\n", i);
+#endif
+       item1 = Fcar (Fcar (tail));
+       CHECK_STRING (item1, 1);
+#ifdef XDEBUG
+       fprintf (stderr, "list_of_panes check pane, i=%d%s\n", i,
+		XSTRING (item1)->data);
+#endif
+       (*panes)[i] = (char *) XSTRING (item1)->data;
+       (*items)[i] = list_of_items ((*vector)+i, (*names)+i, item);
+       /* (*panes)[i] = (char *) xmalloc ((XSTRING (item1)->size)+1);
+	  bcopy (XSTRING (item1)->data, (*panes)[i], XSTRING (item1)->size + 1)
+	  ; */
+    }
+  return i;
+}
+     
+
+list_of_items (vector, names, pane)  /* get list from emacs and put to vector */
+     Lisp_Object **vector;	/* RETURN menu "objects" */
+     char ***names;		/* RETURN line names */
+     Lisp_Object pane;
+{
+  Lisp_Object tail, item, item1;
+  int i;
+
+  if (XTYPE (pane) != Lisp_Cons) pane = wrong_type_argument (Qlistp, pane);
+
+  i= XFASTINT (Flength (pane, 1));
+
+  *vector = (Lisp_Object *) xmalloc (i * sizeof (Lisp_Object));
+  *names = (char **) xmalloc (i * sizeof (char *));
+
+  for (i=0, tail = pane; !NULL (tail); tail = Fcdr (tail), i++)
+    {
+       item = Fcar (tail);
+       if (XTYPE (item) != Lisp_Cons) (void) wrong_type_argument (Qlistp, item);
+#ifdef XDEBUG
+       fprintf (stderr, "list_of_items check tail, i=%d\n", i);
+#endif
+       (*vector)[i] =  Fcdr (item);
+       item1 = Fcar (item);
+       CHECK_STRING (item1, 1);
+#ifdef XDEBUG
+       fprintf (stderr, "list_of_items check item, i=%d%s\n", i,
+		XSTRING (item1)->data);
+#endif
+       (*names)[i] = (char *) XSTRING (item1)->data;
+    }
+  return i;
+}