Mercurial > emacs
changeset 118:49342840ba00
Initial revision
| author | Jim Blandy <jimb@redhat.com> |
|---|---|
| date | Mon, 12 Nov 1990 20:20:45 +0000 |
| parents | 08356dc1077c |
| children | 7cfabf2a8964 |
| files | src/casefiddle.c src/casetab.c src/marker.c src/ralloc.c src/unexhp9k800.c src/vms-pp.c src/vmsproc.c src/xmenu.c |
| diffstat | 8 files changed, 2938 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/casefiddle.c Mon Nov 12 20:20:45 1990 +0000 @@ -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"); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/casetab.c Mon Nov 12 20:20:45 1990 +0000 @@ -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 +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/marker.c Mon Nov 12 20:20:45 1990 +0000 @@ -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); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/ralloc.c Mon Nov 12 20:20:45 1990 +0000 @@ -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 (); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/unexhp9k800.c Mon Nov 12 20:20:45 1990 +0000 @@ -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 */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/vms-pp.c Mon Nov 12 20:20:45 1990 +0000 @@ -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); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/vmsproc.c Mon Nov 12 20:20:45 1990 +0000 @@ -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 */ +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/xmenu.c Mon Nov 12 20:20:45 1990 +0000 @@ -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; +}