aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authorJim Blandy1990-11-12 20:20:45 +0000
committerJim Blandy1990-11-12 20:20:45 +0000
commitdcfdbac7bb0fd364ddf542ed10b9ff2271c37096 (patch)
treeddf67a3f258cffea86f4359b430a7171f97babb9 /src
parent8a281f86e1a71be3a15402fef758bbd19837007e (diff)
downloademacs-dcfdbac7bb0fd364ddf542ed10b9ff2271c37096.tar.gz
emacs-dcfdbac7bb0fd364ddf542ed10b9ff2271c37096.zip
Initial revision
Diffstat (limited to 'src')
-rw-r--r--src/casefiddle.c268
-rw-r--r--src/casetab.c250
-rw-r--r--src/marker.c295
-rw-r--r--src/ralloc.c426
-rw-r--r--src/unexhp9k800.c293
-rw-r--r--src/vms-pp.c242
-rw-r--r--src/vmsproc.c786
-rw-r--r--src/xmenu.c378
8 files changed, 2938 insertions, 0 deletions
diff --git a/src/casefiddle.c b/src/casefiddle.c
new file mode 100644
index 00000000000..d508deb5d60
--- /dev/null
+++ b/src/casefiddle.c
@@ -0,0 +1,268 @@
1/* GNU Emacs case conversion functions.
2 Copyright (C) 1985 Free Software Foundation, Inc.
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 1, or (at your option)
9any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs; see the file COPYING. If not, write to
18the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
19
20
21#include "config.h"
22#include "lisp.h"
23#include "buffer.h"
24#include "commands.h"
25#include "syntax.h"
26
27enum case_action {CASE_UP, CASE_DOWN, CASE_CAPITALIZE, CASE_CAPITALIZE_UP};
28
29Lisp_Object
30casify_object (flag, obj)
31 enum case_action flag;
32 Lisp_Object obj;
33{
34 register int i, c, len;
35 register int inword = flag == CASE_DOWN;
36
37 while (1)
38 {
39 if (XTYPE (obj) == Lisp_Int)
40 {
41 c = XINT (obj);
42 if (c >= 0 && c <= 0400)
43 {
44 if (inword)
45 XFASTINT (obj) = DOWNCASE (c);
46 else if (!UPPERCASEP (c))
47 XFASTINT (obj) = UPCASE1 (c);
48 }
49 return obj;
50 }
51 if (XTYPE (obj) == Lisp_String)
52 {
53 obj = Fcopy_sequence (obj);
54 len = XSTRING (obj)->size;
55 for (i = 0; i < len; i++)
56 {
57 c = XSTRING (obj)->data[i];
58 if (inword)
59 c = DOWNCASE (c);
60 else if (!UPPERCASEP (c))
61 c = UPCASE1 (c);
62 XSTRING (obj)->data[i] = c;
63 if (flag == CASE_CAPITALIZE)
64 inword = SYNTAX (c) == Sword;
65 }
66 return obj;
67 }
68 obj = wrong_type_argument (Qchar_or_string_p, obj, 0);
69 }
70}
71
72DEFUN ("upcase", Fupcase, Supcase, 1, 1, 0,
73 "Convert argument to upper case and return that.\n\
74The argument may be a character or string. The result has the same type.\n\
75The argument object is not altered. See also `capitalize'.")
76 (obj)
77 Lisp_Object obj;
78{
79 return casify_object (CASE_UP, obj);
80}
81
82DEFUN ("downcase", Fdowncase, Sdowncase, 1, 1, 0,
83 "Convert argument to lower case and return that.\n\
84The argument may be a character or string. The result has the same type.\n\
85The argument object is not altered.")
86 (obj)
87 Lisp_Object obj;
88{
89 return casify_object (CASE_DOWN, obj);
90}
91
92DEFUN ("capitalize", Fcapitalize, Scapitalize, 1, 1, 0,
93 "Convert argument to capitalized form and return that.\n\
94This means that each word's first character is upper case\n\
95and the rest is lower case.\n\
96The argument may be a character or string. The result has the same type.\n\
97The argument object is not altered.")
98 (obj)
99 Lisp_Object obj;
100{
101 return casify_object (CASE_CAPITALIZE, obj);
102}
103
104/* flag is CASE_UP, CASE_DOWN or CASE_CAPITALIZE or CASE_CAPITALIZE_UP.
105 b and e specify range of buffer to operate on. */
106
107casify_region (flag, b, e)
108 enum case_action flag;
109 Lisp_Object b, e;
110{
111 register int i;
112 register int c;
113 register int inword = flag == CASE_DOWN;
114
115 if (EQ (b, e))
116 /* Not modifying because nothing marked */
117 return;
118
119 validate_region (&b, &e);
120 modify_region (XFASTINT (b), XFASTINT (e));
121 record_change (XFASTINT (b), XFASTINT (e) - XFASTINT (b));
122
123 for (i = XFASTINT (b); i < XFASTINT (e); i++)
124 {
125 c = FETCH_CHAR (i);
126 if (inword && flag != CASE_CAPITALIZE_UP)
127 c = DOWNCASE (c);
128 else if (!UPPERCASEP (c)
129 && (!inword || flag != CASE_CAPITALIZE_UP))
130 c = UPCASE1 (c);
131 FETCH_CHAR (i) = c;
132 if ((int) flag >= (int) CASE_CAPITALIZE)
133 inword = SYNTAX (c) == Sword;
134 }
135
136 signal_after_change (XFASTINT (b),
137 XFASTINT (e) - XFASTINT (b),
138 XFASTINT (e) - XFASTINT (b));
139}
140
141DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 2, "r",
142 "Convert the region to upper case. In programs, wants two arguments.\n\
143These arguments specify the starting and ending character numbers of\n\
144the region to operate on. When used as a command, the text between\n\
145point and the mark is operated on.\n\
146See also `capitalize-region'.")
147 (b, e)
148 Lisp_Object b, e;
149{
150 casify_region (CASE_UP, b, e);
151 return Qnil;
152}
153
154DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 2, "r",
155 "Convert the region to lower case. In programs, wants two arguments.\n\
156These arguments specify the starting and ending character numbers of\n\
157the region to operate on. When used as a command, the text between\n\
158point and the mark is operated on.")
159 (b, e)
160 Lisp_Object b, e;
161{
162 casify_region (CASE_DOWN, b, e);
163 return Qnil;
164}
165
166DEFUN ("capitalize-region", Fcapitalize_region, Scapitalize_region, 2, 2, "r",
167 "Convert the region to capitalized form.\n\
168Capitalized form means each word's first character is upper case\n\
169and the rest of it is lower case.\n\
170In programs, give two arguments, the starting and ending\n\
171character positions to operate on.")
172 (b, e)
173 Lisp_Object b, e;
174{
175 casify_region (CASE_CAPITALIZE, b, e);
176 return Qnil;
177}
178
179/* Like Fcapitalize but change only the initials. */
180
181Lisp_Object
182upcase_initials_region (b, e)
183 Lisp_Object b, e;
184{
185 casify_region (CASE_CAPITALIZE_UP, b, e);
186 return Qnil;
187}
188
189Lisp_Object
190operate_on_word (arg)
191 Lisp_Object arg;
192{
193 Lisp_Object val, end;
194 int farend;
195
196 CHECK_NUMBER (arg, 0);
197 farend = scan_words (point, XINT (arg));
198 if (!farend)
199 farend = XINT (arg) > 0 ? ZV : BEGV;
200
201 end = point > farend ? point : farend;
202 SET_PT (end);
203 XFASTINT (val) = farend;
204
205 return val;
206}
207
208DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p",
209 "Convert following word (or ARG words) to upper case, moving over.\n\
210With negative argument, convert previous words but do not move.\n\
211See also `capitalize-word'.")
212 (arg)
213 Lisp_Object arg;
214{
215 Lisp_Object opoint;
216
217 XFASTINT (opoint) = point;
218 casify_region (CASE_UP, opoint, operate_on_word (arg));
219 return Qnil;
220}
221
222DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
223 "Convert following word (or ARG words) to lower case, moving over.\n\
224With negative argument, convert previous words but do not move.")
225 (arg)
226 Lisp_Object arg;
227{
228 Lisp_Object opoint;
229 XFASTINT (opoint) = point;
230 casify_region (CASE_DOWN, opoint, operate_on_word (arg));
231 return Qnil;
232}
233
234DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
235 "Capitalize the following word (or ARG words), moving over.\n\
236This gives the word(s) a first character in upper case\n\
237and the rest lower case.\n\
238With negative argument, capitalize previous words but do not move.")
239 (arg)
240 Lisp_Object arg;
241{
242 Lisp_Object opoint;
243 XFASTINT (opoint) = point;
244 casify_region (CASE_CAPITALIZE, opoint, operate_on_word (arg));
245 return Qnil;
246}
247
248syms_of_casefiddle ()
249{
250 defsubr (&Supcase);
251 defsubr (&Sdowncase);
252 defsubr (&Scapitalize);
253 defsubr (&Supcase_region);
254 defsubr (&Sdowncase_region);
255 defsubr (&Scapitalize_region);
256 defsubr (&Supcase_word);
257 defsubr (&Sdowncase_word);
258 defsubr (&Scapitalize_word);
259}
260
261keys_of_casefiddle ()
262{
263 initial_define_key (control_x_map, Ctl('U'), "upcase-region");
264 initial_define_key (control_x_map, Ctl('L'), "downcase-region");
265 initial_define_key (meta_map, 'u', "upcase-word");
266 initial_define_key (meta_map, 'l', "downcase-word");
267 initial_define_key (meta_map, 'c', "capitalize-word");
268}
diff --git a/src/casetab.c b/src/casetab.c
new file mode 100644
index 00000000000..6d419bfe30f
--- /dev/null
+++ b/src/casetab.c
@@ -0,0 +1,250 @@
1/* GNU Emacs routines to deal with case tables.
2 Copyright (C) 1987 Free Software Foundation, Inc.
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 1, or (at your option)
9any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs; see the file COPYING. If not, write to
18the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
19
20/* Written by Howard Gayle. See chartab.c for details. */
21
22#include "config.h"
23#include "lisp.h"
24#include "buffer.h"
25
26Lisp_Object Qcase_table_p;
27Lisp_Object Vascii_downcase_table, Vascii_upcase_table;
28Lisp_Object Vascii_canon_table, Vascii_eqv_table;
29
30void compute_trt_inverse ();
31
32DEFUN ("case-table-p", Fcase_table_p, Scase_table_p, 1, 1, 0,
33 "Return t iff ARG is a case table.\n\
34See `set-case-table' for more information on these data structures.")
35 (table)
36 Lisp_Object table;
37{
38 Lisp_Object down, up, canon, eqv;
39 down = Fcar_safe (table);
40 up = Fcar_safe (Fcdr_safe (table));
41 canon = Fcar_safe (Fcdr_safe (Fcdr_safe (table)));
42 eqv = Fcar_safe (Fcdr_safe (Fcdr_safe (Fcdr_safe (table))));
43
44#define STRING256_P(obj) \
45 (XTYPE (obj) == Lisp_String && XSTRING (obj)->size == 256)
46
47 return (STRING256_P (down)
48 && (NULL (up) || STRING256_P (up))
49 && ((NULL (canon) && NULL (eqv))
50 || (STRING256_P (canon) && STRING256_P (eqv)))
51 ? Qt : Qnil);
52}
53
54static Lisp_Object
55check_case_table (obj)
56 Lisp_Object obj;
57{
58 register Lisp_Object tem;
59
60 while (tem = Fcase_table_p (obj), NULL (tem))
61 obj = wrong_type_argument (Qcase_table_p, obj, 0);
62 return (obj);
63}
64
65DEFUN ("current-case-table", Fcurrent_case_table, Scurrent_case_table, 0, 0, 0,
66 "Return the case table of the current buffer.")
67 ()
68{
69 Lisp_Object down, up, canon, eqv;
70
71 down = current_buffer->downcase_table;
72 up = current_buffer->upcase_table;
73 canon = current_buffer->case_canon_table;
74 eqv = current_buffer->case_eqv_table;
75
76 return Fcons (down, Fcons (up, Fcons (canon, Fcons (eqv, Qnil))));
77}
78
79DEFUN ("standard-case-table", Fstandard_case_table,
80 Sstandard_case_table, 0, 0, 0,
81 "Return the standard case table.\n\
82This is the one used for new buffers.")
83 ()
84{
85 return Fcons (Vascii_downcase_table,
86 Fcons (Vascii_upcase_table,
87 Fcons (Vascii_canon_table,
88 Fcons (Vascii_eqv_table, Qnil))));
89}
90
91DEFUN ("set-case-table", Fset_case_table, Sset_case_table, 1, 1, 0,
92 "Select a new case table for the current buffer.\n\
93A case table is a list (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES)\n\
94 where each element is either nil or a string of length 256.\n\
95DOWNCASE maps each character to its lower-case equivalent.\n\
96UPCASE maps each character to its upper-case equivalent;\n\
97 if lower and upper case characters are in 1-1 correspondence,\n\
98 you may use nil and the upcase table will be deduced from DOWNCASE.\n\
99CANONICALIZE maps each character to a canonical equivalent;\n\
100 any two characters that are related by case-conversion have the same\n\
101 canonical equivalent character.\n\
102EQUIVALENCES is a map that cyclicly permutes each equivalence class\n\
103 (of characters with the same canonical equivalent).\n\
104Both CANONICALIZE and EQUIVALENCES may be nil, in which case\n\
105 both are deduced from DOWNCASE and UPCASE.")
106 (table)
107 Lisp_Object table;
108{
109 set_case_table (table, 0);
110}
111
112DEFUN ("set-standard-case-table",
113 Fset_standard_case_table, Sset_standard_case_table, 1, 1, 0,
114 "Select a new standard case table for new buffers.\n\
115See `set-case-table' for more info on case tables.")
116 (table)
117 Lisp_Object table;
118{
119 set_case_table (table, 1);
120}
121
122set_case_table (table, standard)
123 Lisp_Object table;
124 int standard;
125{
126 Lisp_Object down, up, canon, eqv;
127
128 check_case_table (table);
129
130 down = Fcar_safe (table);
131 up = Fcar_safe (Fcdr_safe (table));
132 canon = Fcar_safe (Fcdr_safe (Fcdr_safe (table)));
133 eqv = Fcar_safe (Fcdr_safe (Fcdr_safe (Fcdr_safe (table))));
134
135 if (NULL (up))
136 {
137 up = Fmake_string (make_number (256), make_number (0));
138 compute_trt_inverse (XSTRING (down)->data, XSTRING (up)->data);
139 }
140
141 if (NULL (canon))
142 {
143 register int i;
144 unsigned char *upvec = XSTRING (up)->data;
145 unsigned char *downvec = XSTRING (down)->data;
146
147 canon = Fmake_string (make_number (256), make_number (0));
148 eqv = Fmake_string (make_number (256), make_number (0));
149
150 /* Set up the CANON vector; for each character,
151 this sequence of upcasing and downcasing ought to
152 get the "preferred" lowercase equivalent. */
153 for (i = 0; i < 256; i++)
154 XSTRING (canon)->data[i] = downvec[upvec[downvec[i]]];
155
156 compute_trt_inverse (XSTRING (canon)->data, XSTRING (eqv)->data);
157 }
158
159 if (standard)
160 {
161 Vascii_downcase_table = down;
162 Vascii_upcase_table = up;
163 Vascii_canon_table = canon;
164 Vascii_eqv_table = eqv;
165 }
166 else
167 {
168 current_buffer->downcase_table = down;
169 current_buffer->upcase_table = up;
170 current_buffer->case_canon_table = canon;
171 current_buffer->case_eqv_table = eqv;
172 }
173 return table;
174}
175
176/* Given a translate table TRT, store the inverse mapping into INVERSE.
177 Since TRT is not one-to-one, INVERSE is not a simple mapping.
178 Instead, it divides the space of characters into equivalence classes.
179 All characters in a given class form one circular list, chained through
180 the elements of INVERSE. */
181
182void
183compute_trt_inverse (trt, inverse)
184 register unsigned char *trt;
185 register unsigned char *inverse;
186{
187 register int i = 0400;
188 register unsigned char c, q;
189
190 while (i--)
191 inverse[i] = i;
192 i = 0400;
193 while (i--)
194 {
195 if ((q = trt[i]) != (unsigned char) i)
196 {
197 c = inverse[q];
198 inverse[q] = i;
199 inverse[i] = c;
200 }
201 }
202}
203
204init_casetab_once ()
205{
206 register int i;
207 Lisp_Object tem;
208
209 tem = Fmake_string (make_number (256), make_number (0));
210 Vascii_downcase_table = tem;
211 Vascii_canon_table = tem;
212
213 for (i = 0; i < 256; i++)
214 XSTRING (tem)->data[i] = (i >= 'A' && i <= 'Z') ? i + 040 : i;
215
216 tem = Fmake_string (make_number (256), make_number (0));
217 Vascii_upcase_table = tem;
218 Vascii_eqv_table = tem;
219
220 for (i = 0; i < 256; i++)
221 XSTRING (tem)->data[i]
222 = ((i >= 'A' && i <= 'Z')
223 ? i + ('a' - 'A')
224 : ((i >= 'a' && i <= 'z')
225 ? i + ('A' - 'a')
226 : i));
227}
228
229syms_of_casetab ()
230{
231 Qcase_table_p = intern ("case-table-p");
232 staticpro (&Qcase_table_p);
233 staticpro (&Vascii_downcase_table);
234 staticpro (&Vascii_upcase_table);
235 staticpro (&Vascii_canon_table);
236 staticpro (&Vascii_eqv_table);
237
238 defsubr (&Scase_table_p);
239 defsubr (&Scurrent_case_table);
240 defsubr (&Sstandard_case_table);
241 defsubr (&Sset_case_table);
242 defsubr (&Sset_standard_case_table);
243
244#if 0
245 DEFVAR_LISP ("ascii-downcase-table", &Vascii_downcase_table,
246 "String mapping ASCII characters to lowercase equivalents.");
247 DEFVAR_LISP ("ascii-upcase-table", &Vascii_upcase_table,
248 "String mapping ASCII characters to uppercase equivalents.");
249#endif
250}
diff --git a/src/marker.c b/src/marker.c
new file mode 100644
index 00000000000..d8c0a89819a
--- /dev/null
+++ b/src/marker.c
@@ -0,0 +1,295 @@
1/* Markers: examining, setting and killing.
2 Copyright (C) 1985 Free Software Foundation, Inc.
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 1, or (at your option)
9any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs; see the file COPYING. If not, write to
18the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
19
20
21#include "config.h"
22#include "lisp.h"
23#include "buffer.h"
24
25/* Operations on markers. */
26
27DEFUN ("marker-buffer", Fmarker_buffer, Smarker_buffer, 1, 1, 0,
28 "Return the buffer that MARKER points into, or nil if none.\n\
29Returns nil if MARKER points into a dead buffer.")
30 (marker)
31 register Lisp_Object marker;
32{
33 register Lisp_Object buf;
34 CHECK_MARKER (marker, 0);
35 if (XMARKER (marker)->buffer)
36 {
37 XSET (buf, Lisp_Buffer, XMARKER (marker)->buffer);
38 /* Return marker's buffer only if it is not dead. */
39 if (!NULL (XBUFFER (buf)->name))
40 return buf;
41 }
42 return Qnil;
43}
44
45DEFUN ("marker-position", Fmarker_position, Smarker_position, 1, 1, 0,
46 "Return the position MARKER points at, as a character number.")
47 (marker)
48 Lisp_Object marker;
49{
50 register Lisp_Object pos;
51 register int i;
52 register struct buffer *buf;
53
54 CHECK_MARKER (marker, 0);
55 if (XMARKER (marker)->buffer)
56 {
57 buf = XMARKER (marker)->buffer;
58 i = XMARKER (marker)->bufpos;
59
60 if (i > BUF_GPT (buf) + BUF_GAP_SIZE (buf))
61 i -= BUF_GAP_SIZE (buf);
62 else if (i > BUF_GPT (buf))
63 i = BUF_GPT (buf);
64
65 if (i < BUF_BEG (buf) || i > BUF_Z (buf))
66 abort ();
67
68 XFASTINT (pos) = i;
69 return pos;
70 }
71 return Qnil;
72}
73
74DEFUN ("set-marker", Fset_marker, Sset_marker, 2, 3, 0,
75 "Position MARKER before character number NUMBER in BUFFER.\n\
76BUFFER defaults to the current buffer.\n\
77If NUMBER is nil, makes marker point nowhere.\n\
78Then it no longer slows down editing in any buffer.\n\
79Returns MARKER.")
80 (marker, pos, buffer)
81 Lisp_Object marker, pos, buffer;
82{
83 register int charno;
84 register struct buffer *b;
85 register struct Lisp_Marker *m;
86
87 CHECK_MARKER (marker, 0);
88 /* If position is nil or a marker that points nowhere,
89 make this marker point nowhere. */
90 if (NULL (pos)
91 || (XTYPE (pos) == Lisp_Marker && !XMARKER (pos)->buffer))
92 {
93 unchain_marker (marker);
94 return marker;
95 }
96
97 CHECK_NUMBER_COERCE_MARKER (pos, 1);
98 if (NULL (buffer))
99 b = current_buffer;
100 else
101 {
102 CHECK_BUFFER (buffer, 1);
103 b = XBUFFER (buffer);
104 /* If buffer is dead, set marker to point nowhere. */
105 if (EQ (b->name, Qnil))
106 {
107 unchain_marker (marker);
108 return marker;
109 }
110 }
111
112 charno = XINT (pos);
113 m = XMARKER (marker);
114
115 if (charno < BUF_BEG (b))
116 charno = BUF_BEG (b);
117 if (charno > BUF_Z (b))
118 charno = BUF_Z (b);
119 if (charno > BUF_GPT (b)) charno += BUF_GAP_SIZE (b);
120 m->bufpos = charno;
121
122 if (m->buffer != b)
123 {
124 unchain_marker (marker);
125 m->chain = b->markers;
126 b->markers = marker;
127 m->buffer = b;
128 }
129
130 return marker;
131}
132
133/* This version of Fset_marker won't let the position
134 be outside the visible part. */
135
136Lisp_Object
137set_marker_restricted (marker, pos, buffer)
138 Lisp_Object marker, pos, buffer;
139{
140 register int charno;
141 register struct buffer *b;
142 register struct Lisp_Marker *m;
143
144 CHECK_MARKER (marker, 0);
145 /* If position is nil or a marker that points nowhere,
146 make this marker point nowhere. */
147 if (NULL (pos) ||
148 (XTYPE (pos) == Lisp_Marker && !XMARKER (pos)->buffer))
149 {
150 unchain_marker (marker);
151 return marker;
152 }
153
154 CHECK_NUMBER_COERCE_MARKER (pos, 1);
155 if (NULL (buffer))
156 b = current_buffer;
157 else
158 {
159 CHECK_BUFFER (buffer, 1);
160 b = XBUFFER (buffer);
161 /* If buffer is dead, set marker to point nowhere. */
162 if (EQ (b->name, Qnil))
163 {
164 unchain_marker (marker);
165 return marker;
166 }
167 }
168
169 charno = XINT (pos);
170 m = XMARKER (marker);
171
172 if (charno < BUF_BEGV (b))
173 charno = BUF_BEGV (b);
174 if (charno > BUF_ZV (b))
175 charno = BUF_ZV (b);
176 if (charno > BUF_GPT (b))
177 charno += BUF_GAP_SIZE (b);
178 m->bufpos = charno;
179
180 if (m->buffer != b)
181 {
182 unchain_marker (marker);
183 m->chain = b->markers;
184 b->markers = marker;
185 m->buffer = b;
186 }
187
188 return marker;
189}
190
191/* This is called during garbage collection,
192 so we must be careful to ignore and preserve mark bits,
193 including those in chain fields of markers. */
194
195unchain_marker (marker)
196 register Lisp_Object marker;
197{
198 register Lisp_Object tail, prev, next;
199 register int omark;
200 register struct buffer *b;
201
202 b = XMARKER (marker)->buffer;
203 if (b == 0)
204 return;
205
206 if (EQ (b->name, Qnil))
207 abort ();
208
209 tail = b->markers;
210 prev = Qnil;
211 while (XSYMBOL (tail) != XSYMBOL (Qnil))
212 {
213 next = XMARKER (tail)->chain;
214 XUNMARK (next);
215
216 if (XMARKER (marker) == XMARKER (tail))
217 {
218 if (NULL (prev))
219 {
220 b->markers = next;
221 /* Deleting first marker from the buffer's chain.
222 Crash if new first marker in chain does not say
223 it belongs to this buffer. */
224 if (!EQ (next, Qnil) && b != XMARKER (next)->buffer)
225 abort ();
226 }
227 else
228 {
229 omark = XMARKBIT (XMARKER (prev)->chain);
230 XMARKER (prev)->chain = next;
231 XSETMARKBIT (XMARKER (prev)->chain, omark);
232 }
233 break;
234 }
235 else
236 prev = tail;
237 tail = next;
238 }
239 XMARKER (marker)->buffer = 0;
240}
241
242marker_position (marker)
243 Lisp_Object marker;
244{
245 register struct Lisp_Marker *m = XMARKER (marker);
246 register struct buffer *buf = m->buffer;
247 register int i = m->bufpos;
248
249 if (!buf)
250 error ("Marker does not point anywhere");
251
252 if (i > BUF_GPT (buf) + BUF_GAP_SIZE (buf))
253 i -= BUF_GAP_SIZE (buf);
254 else if (i > BUF_GPT (buf))
255 i = BUF_GPT (buf);
256
257 if (i < BUF_BEG (buf) || i > BUF_Z (buf))
258 abort ();
259
260 return i;
261}
262
263DEFUN ("copy-marker", Fcopy_marker, Scopy_marker, 1, 1, 0,
264 "Return a new marker pointing at the same place as MARKER.\n\
265If argument is a number, makes a new marker pointing\n\
266at that position in the current buffer.")
267 (marker)
268 register Lisp_Object marker;
269{
270 register Lisp_Object new;
271
272 while (1)
273 {
274 if (XTYPE (marker) == Lisp_Int
275 || XTYPE (marker) == Lisp_Marker)
276 {
277 new = Fmake_marker ();
278 Fset_marker (new, marker,
279 ((XTYPE (marker) == Lisp_Marker)
280 ? Fmarker_buffer (marker)
281 : Qnil));
282 return new;
283 }
284 else
285 marker = wrong_type_argument (Qinteger_or_marker_p, marker);
286 }
287}
288
289syms_of_marker ()
290{
291 defsubr (&Smarker_position);
292 defsubr (&Smarker_buffer);
293 defsubr (&Sset_marker);
294 defsubr (&Scopy_marker);
295}
diff --git a/src/ralloc.c b/src/ralloc.c
new file mode 100644
index 00000000000..1f92b51be88
--- /dev/null
+++ b/src/ralloc.c
@@ -0,0 +1,426 @@
1/* Block-relocating memory allocator.
2 Copyright (C) 1990 Free Software Foundation, Inc.
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 1, or (at your option)
9any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs; see the file COPYING. If not, write to
18the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
19
20/* NOTES:
21
22 Only relocate the blocs neccessary for SIZE in r_alloc_sbrk,
23 rather than all of them. This means allowing for a possible
24 hole between the first bloc and the end of malloc storage. */
25
26#include "config.h"
27#include "lisp.h" /* Needed for xterm.h */
28#undef NULL
29#include "mem_limits.h"
30#include "xterm.h" /* Needed for BLOCK_INPUT */
31
32#define NIL ((POINTER) 0)
33
34
35/* System call to set the break value. */
36extern POINTER sbrk ();
37
38/* The break value, as seen by malloc (). */
39static POINTER virtual_break_value;
40
41/* The break value, viewed by the relocatable blocs. */
42static POINTER break_value;
43
44/* The REAL (i.e., page aligned) break value of the process. */
45static POINTER page_break_value;
46
47/* Macros for rounding. Note that rounding to any value is possible
48 by changing the definition of PAGE. */
49#define PAGE (getpagesize ())
50#define ALIGNED(addr) (((unsigned int) (addr) & (PAGE - 1)) == 0)
51#define ROUNDUP(size) (((unsigned int) (size) + PAGE) & ~(PAGE - 1))
52#define ROUND_TO_PAGE(addr) (addr & (~(PAGE - 1)))
53#define EXCEEDS_ELISP_PTR(ptr) ((unsigned int) (ptr) >> VALBITS)
54
55/* Level of warnings issued. */
56static int warnlevel;
57
58/* Function to call to issue a warning;
59 0 means don't issue them. */
60static void (*warnfunction) ();
61
62static void
63check_memory_limits (address)
64 POINTER address;
65{
66 SIZE data_size = address - data_space_start;
67
68 switch (warnlevel)
69 {
70 case 0:
71 if (data_size > (lim_data / 4) * 3)
72 {
73 warnlevel++;
74 (*warnfunction) ("Warning: past 75% of memory limit");
75 }
76 break;
77
78 case 1:
79 if (data_size > (lim_data / 20) * 17)
80 {
81 warnlevel++;
82 (*warnfunction) ("Warning: past 85% of memory limit");
83 }
84 break;
85
86 case 2:
87 if (data_size > (lim_data / 20) * 19)
88 {
89 warnlevel++;
90 (*warnfunction) ("Warning: past 95% of memory limit");
91 }
92 break;
93
94 default:
95 (*warnfunction) ("Warning: past acceptable memory limits");
96 break;
97 }
98
99 if (EXCEEDS_ELISP_PTR (address))
100 (*warnfunction) ("Warning: memory in use exceeds lisp pointer size");
101}
102
103/* Obtain SIZE bytes of space. If enough space is not presently available
104 in our process reserve, (i.e., (page_break_value - break_value)),
105 this means getting more page-aligned space from the system. */
106
107static void
108obtain (size)
109 SIZE size;
110{
111 SIZE already_available = page_break_value - break_value;
112
113 if (already_available < size)
114 {
115 SIZE get = ROUNDUP (size);
116
117 if (warnfunction)
118 check_memory_limits (page_break_value);
119
120 if (((int) sbrk (get)) < 0)
121 abort ();
122
123 page_break_value += get;
124 }
125
126 break_value += size;
127}
128
129/* Obtain SIZE bytes of space and return a pointer to the new area. */
130
131static POINTER
132get_more_space (size)
133 SIZE size;
134{
135 POINTER ptr = break_value;
136 obtain (size);
137 return ptr;
138}
139
140/* Note that SIZE bytes of space have been relinquished by the process.
141 If SIZE is more than a page, return the space the system. */
142
143static void
144relinquish (size)
145 SIZE size;
146{
147 SIZE page_part = ROUND_TO_PAGE (size);
148
149 if (page_part)
150 {
151 if (((int) (sbrk (- page_part))) < 0)
152 abort ();
153
154 page_break_value -= page_part;
155 }
156
157 break_value -= size;
158 bzero (break_value, (size - page_part));
159}
160
161typedef struct bp
162{
163 struct bp *next;
164 struct bp *prev;
165 POINTER *variable;
166 POINTER data;
167 SIZE size;
168} *bloc_ptr;
169
170#define NIL_BLOC ((bloc_ptr) 0)
171#define BLOC_PTR_SIZE (sizeof (struct bp))
172
173/* Head and tail of the list of relocatable blocs. */
174static bloc_ptr first_bloc, last_bloc;
175
176/* Declared in dispnew.c, this version dosen't fuck up if regions overlap. */
177extern void safe_bcopy ();
178
179/* Find the bloc reference by the address in PTR. Returns a pointer
180 to that block. */
181
182static bloc_ptr
183find_bloc (ptr)
184 POINTER *ptr;
185{
186 register bloc_ptr p = first_bloc;
187
188 while (p != NIL_BLOC)
189 {
190 if (p->variable == ptr && p->data == *ptr)
191 return p;
192
193 p = p->next;
194 }
195
196 return p;
197}
198
199/* Allocate a bloc of SIZE bytes and append it to the chain of blocs.
200 Returns a pointer to the new bloc. */
201
202static bloc_ptr
203get_bloc (size)
204 SIZE size;
205{
206 register bloc_ptr new_bloc = (bloc_ptr) malloc (BLOC_PTR_SIZE);
207
208 new_bloc->data = get_more_space (size);
209 new_bloc->size = size;
210 new_bloc->next = NIL_BLOC;
211 new_bloc->variable = NIL;
212
213 if (first_bloc)
214 {
215 new_bloc->prev = last_bloc;
216 last_bloc->next = new_bloc;
217 last_bloc = new_bloc;
218 }
219 else
220 {
221 first_bloc = last_bloc = new_bloc;
222 new_bloc->prev = NIL_BLOC;
223 }
224
225 return new_bloc;
226}
227
228/* Relocate all blocs from BLOC on upward in the list to the zone
229 indicated by ADDRESS. Direction of relocation is determined by
230 the position of ADDRESS relative to BLOC->data.
231
232 Note that ordering of blocs is not affected by this function. */
233
234static void
235relocate_some_blocs (bloc, address)
236 bloc_ptr bloc;
237 POINTER address;
238{
239 register bloc_ptr b;
240 POINTER data_zone = bloc->data;
241 register SIZE data_zone_size = 0;
242 register SIZE offset = bloc->data - address;
243 POINTER new_data_zone = data_zone - offset;
244
245 for (b = bloc; b != NIL_BLOC; b = b->next)
246 {
247 data_zone_size += b->size;
248 b->data -= offset;
249 *b->variable = b->data;
250 }
251
252 safe_bcopy (data_zone, new_data_zone, data_zone_size);
253}
254
255/* Free BLOC from the chain of blocs, relocating any blocs above it
256 and returning BLOC->size bytes to the free area. */
257
258static void
259free_bloc (bloc)
260 bloc_ptr bloc;
261{
262 if (bloc == first_bloc && bloc == last_bloc)
263 {
264 first_bloc = last_bloc = NIL_BLOC;
265 }
266 else if (bloc == last_bloc)
267 {
268 last_bloc = bloc->prev;
269 last_bloc->next = NIL_BLOC;
270 }
271 else if (bloc == first_bloc)
272 {
273 first_bloc = bloc->next;
274 first_bloc->prev = NIL_BLOC;
275 relocate_some_blocs (bloc->next, bloc->data);
276 }
277 else
278 {
279 bloc->next->prev = bloc->prev;
280 bloc->prev->next = bloc->next;
281 relocate_some_blocs (bloc->next, bloc->data);
282 }
283
284 relinquish (bloc->size);
285 free (bloc);
286}
287
288static int use_relocatable_buffers;
289
290/* Obtain SIZE bytes of storage from the free pool, or the system,
291 as neccessary. If relocatable blocs are in use, this means
292 relocating them. */
293
294POINTER
295r_alloc_sbrk (size)
296 long size;
297{
298 POINTER ptr;
299
300 if (! use_relocatable_buffers)
301 return sbrk (size);
302
303 if (size > 0)
304 {
305 obtain (size);
306 if (first_bloc)
307 {
308 relocate_some_blocs (first_bloc, first_bloc->data + size);
309 bzero (virtual_break_value, size);
310 }
311 }
312 else if (size < 0)
313 {
314 if (first_bloc)
315 relocate_some_blocs (first_bloc, first_bloc->data + size);
316 relinquish (- size);
317 }
318
319 ptr = virtual_break_value;
320 virtual_break_value += size;
321 return ptr;
322}
323
324/* Allocate a relocatable bloc of storage of size SIZE. A pointer to
325 the data is returned in *PTR. PTR is thus the address of some variable
326 which will use the data area. */
327
328POINTER
329r_alloc (ptr, size)
330 POINTER *ptr;
331 SIZE size;
332{
333 register bloc_ptr new_bloc;
334
335 BLOCK_INPUT;
336 new_bloc = get_bloc (size);
337 new_bloc->variable = ptr;
338 *ptr = new_bloc->data;
339 UNBLOCK_INPUT;
340
341 return *ptr;
342}
343
344/* Free a bloc of relocatable storage whose data is pointed to by PTR. */
345
346void
347r_alloc_free (ptr)
348 register POINTER *ptr;
349{
350 register bloc_ptr dead_bloc;
351
352 BLOCK_INPUT;
353 dead_bloc = find_bloc (ptr);
354 if (dead_bloc == NIL_BLOC)
355 abort ();
356
357 free_bloc (dead_bloc);
358 UNBLOCK_INPUT;
359}
360
361/* Given a pointer at address PTR to relocatable data, resize it
362 to SIZE. This is done by obtaining a new block and freeing the
363 old, unless SIZE is less than or equal to the current bloc size,
364 in which case nothing happens and the current value is returned.
365
366 The contents of PTR is changed to reflect the new bloc, and this
367 value is returned. */
368
369POINTER
370r_re_alloc (ptr, size)
371 POINTER *ptr;
372 SIZE size;
373{
374 register bloc_ptr old_bloc, new_bloc;
375
376 BLOCK_INPUT;
377 old_bloc = find_bloc (ptr);
378 if (old_bloc == NIL_BLOC)
379 abort ();
380
381 if (size <= old_bloc->size)
382 return *ptr;
383
384 new_bloc = get_bloc (size);
385 new_bloc->variable = ptr;
386 safe_bcopy (old_bloc->data, new_bloc->data, old_bloc->size);
387 *ptr = new_bloc->data;
388
389 free_bloc (old_bloc);
390 UNBLOCK_INPUT;
391
392 return *ptr;
393}
394
395/* The hook `malloc' uses for the function which gets more space
396 from the system. */
397extern POINTER (*__morecore) ();
398
399/* Intialize various things for memory allocation. */
400
401void
402malloc_init (start, warn_func)
403 POINTER start;
404 void (*warn_func) ();
405{
406 static int malloc_initialized = 0;
407
408 if (start)
409 data_space_start = start;
410
411 if (malloc_initialized)
412 return;
413
414 malloc_initialized = 1;
415 __morecore = r_alloc_sbrk;
416 virtual_break_value = break_value = sbrk (0);
417 page_break_value = (POINTER) ROUNDUP (break_value);
418 bzero (break_value, (page_break_value - break_value));
419 use_relocatable_buffers = 1;
420
421 lim_data = 0;
422 warnlevel = 0;
423 warnfunction = warn_func;
424
425 get_lim_data ();
426}
diff --git a/src/unexhp9k800.c b/src/unexhp9k800.c
new file mode 100644
index 00000000000..259b9318514
--- /dev/null
+++ b/src/unexhp9k800.c
@@ -0,0 +1,293 @@
1/* Unexec for HP 9000 Series 800 machines.
2 Bob Desinger <hpsemc!bd@hplabs.hp.com>
3
4 Note that the GNU project considers support for HP operation a
5 peripheral activity which should not be allowed to divert effort
6 from development of the GNU system. Changes in this code will be
7 installed when users send them in, but aside from that we don't
8 plan to think about it, or about whether other Emacs maintenance
9 might break it.
10
11
12 Unexec creates a copy of the old a.out file, and replaces the old data
13 area with the current data area. When the new file is executed, the
14 process will see the same data structures and data values that the
15 original process had when unexec was called.
16
17 Unlike other versions of unexec, this one copies symbol table and
18 debug information to the new a.out file. Thus, the new a.out file
19 may be debugged with symbolic debuggers.
20
21 If you fix any bugs in this, I'd like to incorporate your fixes.
22 Send them to uunet!hpda!hpsemc!jmorris or jmorris%hpsemc@hplabs.HP.COM.
23
24 CAVEATS:
25 This routine saves the current value of all static and external
26 variables. This means that any data structure that needs to be
27 initialized must be explicitly reset. Variables will not have their
28 expected default values.
29
30 Unfortunately, the HP-UX signal handler has internal initialization
31 flags which are not explicitly reset. Thus, for signals to work in
32 conjunction with this routine, the following code must executed when
33 the new process starts up.
34
35 void _sigreturn();
36 ...
37 sigsetreturn(_sigreturn);
38*/
39
40#include <stdio.h>
41#include <fcntl.h>
42#include <errno.h>
43
44#include <a.out.h>
45
46#define NBPG 2048
47#define roundup(x,n) ( ( (x)+(n-1) ) & ~(n-1) ) /* n is power of 2 */
48#define min(x,y) ( ((x)<(y))?(x):(y) )
49
50
51/* Create a new a.out file, same as old but with current data space */
52
53unexec(new_name, old_name, new_end_of_text, dummy1, dummy2)
54 char new_name[]; /* name of the new a.out file to be created */
55 char old_name[]; /* name of the old a.out file */
56 char *new_end_of_text; /* ptr to new edata/etext; NOT USED YET */
57 int dummy1, dummy2; /* not used by emacs */
58{
59 int old, new;
60 int old_size, new_size;
61 struct header hdr;
62 struct som_exec_auxhdr auxhdr;
63
64 /* For the greatest flexibility, should create a temporary file in
65 the same directory as the new file. When everything is complete,
66 rename the temp file to the new name.
67 This way, a program could update its own a.out file even while
68 it is still executing. If problems occur, everything is still
69 intact. NOT implemented. */
70
71 /* Open the input and output a.out files */
72 old = open(old_name, O_RDONLY);
73 if (old < 0)
74 { perror(old_name); exit(1); }
75 new = open(new_name, O_CREAT|O_RDWR|O_TRUNC, 0777);
76 if (new < 0)
77 { perror(new_name); exit(1); }
78
79 /* Read the old headers */
80 read_header(old, &hdr, &auxhdr);
81
82 /* Decide how large the new and old data areas are */
83 old_size = auxhdr.exec_dsize;
84 new_size = sbrk(0) - auxhdr.exec_dmem;
85
86 /* Copy the old file to the new, up to the data space */
87 lseek(old, 0, 0);
88 copy_file(old, new, auxhdr.exec_dfile);
89
90 /* Skip the old data segment and write a new one */
91 lseek(old, old_size, 1);
92 save_data_space(new, &hdr, &auxhdr, new_size);
93
94 /* Copy the rest of the file */
95 copy_rest(old, new);
96
97 /* Update file pointers since we probably changed size of data area */
98 update_file_ptrs(new, &hdr, &auxhdr, auxhdr.exec_dfile, new_size-old_size);
99
100 /* Save the modified header */
101 write_header(new, &hdr, &auxhdr);
102
103 /* Close the binary file */
104 close(old);
105 close(new);
106 exit(0);
107}
108
109/* Save current data space in the file, update header. */
110
111save_data_space(file, hdr, auxhdr, size)
112 int file;
113 struct header *hdr;
114 struct som_exec_auxhdr *auxhdr;
115 int size;
116{
117 /* Write the entire data space out to the file */
118 if (write(file, auxhdr->exec_dmem, size) != size)
119 { perror("Can't save new data space"); exit(1); }
120
121 /* Update the header to reflect the new data size */
122 auxhdr->exec_dsize = size;
123 auxhdr->exec_bsize = 0;
124}
125
126/* Update the values of file pointers when something is inserted. */
127
128update_file_ptrs(file, hdr, auxhdr, location, offset)
129 int file;
130 struct header *hdr;
131 struct som_exec_auxhdr *auxhdr;
132 unsigned int location;
133 int offset;
134{
135 struct subspace_dictionary_record subspace;
136 int i;
137
138 /* Increase the overall size of the module */
139 hdr->som_length += offset;
140
141 /* Update the various file pointers in the header */
142#define update(ptr) if (ptr > location) ptr = ptr + offset
143 update(hdr->aux_header_location);
144 update(hdr->space_strings_location);
145 update(hdr->init_array_location);
146 update(hdr->compiler_location);
147 update(hdr->symbol_location);
148 update(hdr->fixup_request_location);
149 update(hdr->symbol_strings_location);
150 update(hdr->unloadable_sp_location);
151 update(auxhdr->exec_tfile);
152 update(auxhdr->exec_dfile);
153
154 /* Do for each subspace dictionary entry */
155 lseek(file, hdr->subspace_location, 0);
156 for (i = 0; i < hdr->subspace_total; i++)
157 {
158 if (read(file, &subspace, sizeof(subspace)) != sizeof(subspace))
159 { perror("Can't read subspace record"); exit(1); }
160
161 /* If subspace has a file location, update it */
162 if (subspace.initialization_length > 0
163 && subspace.file_loc_init_value > location)
164 {
165 subspace.file_loc_init_value += offset;
166 lseek(file, -sizeof(subspace), 1);
167 if (write(file, &subspace, sizeof(subspace)) != sizeof(subspace))
168 { perror("Can't update subspace record"); exit(1); }
169 }
170 }
171
172 /* Do for each initialization pointer record */
173 /* (I don't think it applies to executable files, only relocatables) */
174#undef update
175}
176
177/* Read in the header records from an a.out file. */
178
179read_header(file, hdr, auxhdr)
180 int file;
181 struct header *hdr;
182 struct som_exec_auxhdr *auxhdr;
183{
184
185 /* Read the header in */
186 lseek(file, 0, 0);
187 if (read(file, hdr, sizeof(*hdr)) != sizeof(*hdr))
188 { perror("Couldn't read header from a.out file"); exit(1); }
189
190 if (hdr->a_magic != EXEC_MAGIC && hdr->a_magic != SHARE_MAGIC
191 && hdr->a_magic != DEMAND_MAGIC)
192 {
193 fprintf(stderr, "a.out file doesn't have legal magic number\n");
194 exit(1);
195 }
196
197 lseek(file, hdr->aux_header_location, 0);
198 if (read(file, auxhdr, sizeof(*auxhdr)) != sizeof(*auxhdr))
199 {
200 perror("Couldn't read auxiliary header from a.out file");
201 exit(1);
202 }
203}
204
205/* Write out the header records into an a.out file. */
206
207write_header(file, hdr, auxhdr)
208 int file;
209 struct header *hdr;
210 struct som_exec_auxhdr *auxhdr;
211{
212 /* Update the checksum */
213 hdr->checksum = calculate_checksum(hdr);
214
215 /* Write the header back into the a.out file */
216 lseek(file, 0, 0);
217 if (write(file, hdr, sizeof(*hdr)) != sizeof(*hdr))
218 { perror("Couldn't write header to a.out file"); exit(1); }
219 lseek(file, hdr->aux_header_location, 0);
220 if (write(file, auxhdr, sizeof(*auxhdr)) != sizeof(*auxhdr))
221 { perror("Couldn't write auxiliary header to a.out file"); exit(1); }
222}
223
224/* Calculate the checksum of a SOM header record. */
225
226calculate_checksum(hdr)
227 struct header *hdr;
228{
229 int checksum, i, *ptr;
230
231 checksum = 0; ptr = (int *) hdr;
232
233 for (i=0; i<sizeof(*hdr)/sizeof(int)-1; i++)
234 checksum ^= ptr[i];
235
236 return(checksum);
237}
238
239/* Copy size bytes from the old file to the new one. */
240
241copy_file(old, new, size)
242 int new, old;
243 int size;
244{
245 int len;
246 int buffer[8196]; /* word aligned will be faster */
247
248 for (; size > 0; size -= len)
249 {
250 len = min(size, sizeof(buffer));
251 if (read(old, buffer, len) != len)
252 { perror("Read failure on a.out file"); exit(1); }
253 if (write(new, buffer, len) != len)
254 { perror("Write failure in a.out file"); exit(1); }
255 }
256}
257
258/* Copy the rest of the file, up to EOF. */
259
260copy_rest(old, new)
261 int new, old;
262{
263 int buffer[4096];
264 int len;
265
266 /* Copy bytes until end of file or error */
267 while ( (len = read(old, buffer, sizeof(buffer))) > 0)
268 if (write(new, buffer, len) != len) break;
269
270 if (len != 0)
271 { perror("Unable to copy the rest of the file"); exit(1); }
272}
273
274#ifdef DEBUG
275display_header(hdr, auxhdr)
276 struct header *hdr;
277 struct som_exec_auxhdr *auxhdr;
278{
279 /* Display the header information (debug) */
280 printf("\n\nFILE HEADER\n");
281 printf("magic number %d \n", hdr->a_magic);
282 printf("text loc %.8x size %d \n", auxhdr->exec_tmem, auxhdr->exec_tsize);
283 printf("data loc %.8x size %d \n", auxhdr->exec_dmem, auxhdr->exec_dsize);
284 printf("entry %x \n", auxhdr->exec_entry);
285 printf("Bss segment size %u\n", auxhdr->exec_bsize);
286 printf("\n");
287 printf("data file loc %d size %d\n",
288 auxhdr->exec_dfile, auxhdr->exec_dsize);
289 printf("som_length %d\n", hdr->som_length);
290 printf("unloadable sploc %d size %d\n",
291 hdr->unloadable_sp_location, hdr->unloadable_sp_size);
292}
293#endif /* DEBUG */
diff --git a/src/vms-pp.c b/src/vms-pp.c
new file mode 100644
index 00000000000..fdfcd9c46a1
--- /dev/null
+++ b/src/vms-pp.c
@@ -0,0 +1,242 @@
1/* vms_pp - preprocess emacs files in such a way that they can be
2 * compiled on VMS without warnings.
3 * Copyright (C) 1986 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7GNU Emacs is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 1, or (at your option)
10any later version.
11
12GNU Emacs is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15GNU General Public License for more details.
16
17You should have received a copy of the GNU General Public License
18along with GNU Emacs; see the file COPYING. If not, write to
19the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
20
21 *
22 * Usage:
23 * vms_pp infile outfile
24 * implicit inputs:
25 * The file "vms_pp.trans" has the names and their translations.
26 * description:
27 * Vms_pp takes the input file and scans it, replacing the long
28 * names with shorter names according to the table read in from
29 * vms_pp.trans. The line is then written to the output file.
30 *
31 * Additionally, the "#undef foo" construct is replaced with:
32 * #ifdef foo
33 * #undef foo
34 * #endif
35 *
36 * The construct #if defined(foo) is replaced with
37 * #ifdef foo
38 * #define foo_VAL 1
39 * #else
40 * #define foo_VAL 0
41 * #endif
42 * #define defined(XX) XX_val
43 * #if defined(foo)
44 *
45 * This last contruction only works on single line #if's and takes
46 * advantage of a questionable C pre-processor trick. If there are
47 * comments within the #if, that contain "defined", then this will
48 * bomb.
49 */
50#include <stdio.h>
51
52#define Max_table 100
53#define Table_name "vms_pp.trans"
54#define Word_member \
55"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$"
56
57static FILE *in,*out; /* read from, write to */
58struct item { /* symbol table entries */
59 char *name;
60 char *value;
61};
62static struct item name_table[Max_table]; /* symbol table */
63static int defined_defined = 0; /* small optimization */
64
65main(argc,argv) int argc; char **argv; {
66 char buffer[1024];
67
68 if(argc != 3) { /* check argument count */
69 fprintf(stderr,"usage: vms_pp infile outfile");
70 exit();
71 }
72 init_table(); /* read in translation table */
73
74/* open input and output files
75 */
76 if((in = fopen(argv[1],"r")) == NULL) {
77 fprintf(stderr,"vms_pp: unable to open file '%s'",argv[1]);
78 exit();
79 }
80 if((out = fopen(argv[2],"w")) == NULL) {
81 fprintf(stderr,"vms_pp: unable to create file '%s'",argv[2]);
82 exit();
83 }
84
85 while(fgets(buffer,1023,in) != NULL) { /* loop through buffer until end */
86 process_line(buffer); /* process the line */
87 fputs(buffer,out); /* write out the line */
88 }
89}
90
91/* buy - allocate and copy a string
92 */
93static char *buy(str) char *str; {
94 char *temp;
95
96 if(!(temp = malloc(strlen(str)+1))) {
97 fprintf(stderr,"vms_pp: can't allocate memory");
98 exit();
99 }
100 strcpy(temp,str);
101 return temp;
102}
103
104/* gather_word - return a buffer full of the next word
105 */
106static char *gather_word(ptr,word) char *ptr, *word;{
107 for(; strchr(Word_member,*ptr); ptr++,word++)
108 *word = *ptr;
109 *word = 0;
110 return ptr;
111}
112
113/* skip_white - skip white space
114 */
115static char *skip_white(ptr) char *ptr; {
116 while(*ptr == ' ' || *ptr == '\t')
117 ptr++;
118 return ptr;
119}
120
121/* init_table - initialize translation table.
122 */
123init_table() {
124 char buf[256],*ptr,word[128];
125 FILE *in;
126 int i;
127
128 if((in = fopen(Table_name,"r")) == NULL) { /* open file */
129 fprintf(stderr,"vms_pp: can't open '%s'",Table_name);
130 exit();
131 }
132 for(i = 0; fgets(buf,255,in) != NULL;) { /* loop through lines */
133 ptr = skip_white(buf);
134 if(*ptr == '!') /* skip comments */
135 continue;
136 ptr = gather_word(ptr,word); /* get long word */
137 if(*word == 0) { /* bad entry */
138 fprintf(stderr,"vms_pp: bad input line '%s'\n",buf);
139 continue;
140 }
141 name_table[i].name = buy(word); /* set up the name */
142 ptr = skip_white(ptr); /* skip white space */
143 ptr = gather_word(ptr,word); /* get equivalent name */
144 if(*word == 0) { /* bad entry */
145 fprintf(stderr,"vms_pp: bad input line '%s'\n",buf);
146 continue;
147 }
148 name_table[i].value = buy(word); /* and the equivalent name */
149 i++; /* increment to next position */
150 }
151 for(; i < Max_table; i++) /* mark rest as unused */
152 name_table[i].name = 0;
153}
154
155/* process_line - do actual line processing
156 */
157process_line(buf) char *buf; {
158 char *in_ptr,*out_ptr;
159 char word[128],*ptr;
160 int len;
161
162 check_pp(buf); /* check for preprocessor lines */
163
164 for(in_ptr = out_ptr = buf; *in_ptr;) {
165 if(!strchr(Word_member,*in_ptr)) /* non alpha-numeric? just copy */
166 *out_ptr++ = *in_ptr++;
167 else {
168 in_ptr = gather_word(in_ptr,word); /* get the 'word' */
169 if(strlen(word) > 31) /* length is too long */
170 replace_word(word); /* replace the word */
171 for(ptr = word; *ptr; ptr++,out_ptr++) /* copy out the word */
172 *out_ptr = *ptr;
173 }
174 }
175 *out_ptr = 0;
176}
177
178/* check_pp - check for preprocessor lines
179 */
180check_pp(buf) char *buf; {
181 char *ptr,*p;
182 char word[128];
183
184 ptr = skip_white(buf); /* skip white space */
185 if(*ptr != '#') /* is this a preprocessor line? */
186 return; /* no, just return */
187
188 ptr = skip_white(++ptr); /* skip white */
189 ptr = gather_word(ptr,word); /* get command word */
190 if(!strcmp("undef",word)) { /* undef? */
191 ptr = skip_white(ptr);
192 ptr = gather_word(ptr,word); /* get the symbol to undef */
193 fprintf(out,"#ifdef %s\n",word);
194 fputs(buf,out);
195 strcpy(buf,"#endif");
196 return;
197 }
198 if(!strcmp("if",word)) { /* check for if */
199 for(;;) {
200 ptr = strchr(ptr,'d'); /* look for d in defined */
201 if(!ptr) /* are we done? */
202 return;
203 if(strchr(Word_member,*(ptr-1))){ /* at beginning of word? */
204 ptr++; continue; /* no, continue looking */
205 }
206 ptr = gather_word(ptr,word); /* get the word */
207 if(strcmp(word,"defined")) /* skip if not defined */
208 continue;
209 ptr = skip_white(ptr); /* skip white */
210 if(*ptr != '(') /* look for open paren */
211 continue; /* error, continue */
212 ptr++; /* skip paren */
213 ptr = skip_white(ptr); /* more white skipping */
214 ptr = gather_word(ptr,word); /* get the thing to test */
215 if(!*word) /* null word is bad */
216 continue;
217 fprintf(out,"#ifdef %s\n",word); /* generate the code */
218 fprintf(out,"#define %s_VAL 1\n",word);
219 fprintf(out,"#else\n");
220 fprintf(out,"#define %s_VAL 0\n",word);
221 fprintf(out,"#endif\n");
222 if(!defined_defined) {
223 fprintf(out,"#define defined(XXX) XXX/**/_VAL\n");
224 defined_defined = 1;
225 }
226 }
227 }
228}
229
230/* replace_word - look the word up in the table, and replace it
231 * if a match is found.
232 */
233replace_word(word) char *word; {
234 int i;
235
236 for(i = 0; i < Max_table && name_table[i].name; i++)
237 if(!strcmp(word,name_table[i].name)) {
238 strcpy(word,name_table[i].value);
239 return;
240 }
241 fprintf(stderr,"couldn't find '%s'\n",word);
242}
diff --git a/src/vmsproc.c b/src/vmsproc.c
new file mode 100644
index 00000000000..35823b32fc1
--- /dev/null
+++ b/src/vmsproc.c
@@ -0,0 +1,786 @@
1/* Interfaces to subprocesses on VMS.
2 Copyright (C) 1988 Free Software Foundation, Inc.
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 1, or (at your option)
9any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs; see the file COPYING. If not, write to
18the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
19
20
21/*
22 Event flag and `select' emulation
23
24 0 is never used
25 1 is the terminal
26 23 is the timer event flag
27 24-31 are reserved by VMS
28*/
29#include <ssdef.h>
30#include <iodef.h>
31#include <dvidef.h>
32#include <clidef.h>
33#include "vmsproc.h"
34
35#define KEYBOARD_EVENT_FLAG 1
36#define TIMER_EVENT_FLAG 23
37
38static VMS_PROC_STUFF procList[MAX_EVENT_FLAGS+1];
39
40get_kbd_event_flag ()
41{
42 /*
43 Return the first event flag for keyboard input.
44 */
45 VMS_PROC_STUFF *vs = &procList[KEYBOARD_EVENT_FLAG];
46
47 vs->busy = 1;
48 vs->pid = 0;
49 return (vs->eventFlag);
50}
51
52get_timer_event_flag ()
53{
54 /*
55 Return the last event flag for use by timeouts
56 */
57 VMS_PROC_STUFF *vs = &procList[TIMER_EVENT_FLAG];
58
59 vs->busy = 1;
60 vs->pid = 0;
61 return (vs->eventFlag);
62}
63
64VMS_PROC_STUFF *
65get_vms_process_stuff ()
66{
67 /*
68 Return a process_stuff structure
69
70 We use 1-23 as our event flags to simplify implementing
71 a VMS `select' call.
72 */
73 int i;
74 VMS_PROC_STUFF *vs;
75
76 for (i=1, vs = procList; i<MAX_EVENT_FLAGS; i++, vs++)
77 {
78 if (!vs->busy)
79 {
80 vs->busy = 1;
81 vs->inputChan = 0;
82 vs->pid = 0;
83 sys$clref (vs->eventFlag);
84 return (vs);
85 }
86 }
87 return ((VMS_PROC_STUFF *)0);
88}
89
90give_back_vms_process_stuff (vs)
91 VMS_PROC_STUFF *vs;
92{
93 /*
94 Return an event flag to our pool
95 */
96 vs->busy = 0;
97 vs->inputChan = 0;
98 vs->pid = 0;
99}
100
101VMS_PROC_STUFF *
102get_vms_process_pointer (pid)
103 int pid;
104{
105 /*
106 Given a pid, return the VMS_STUFF pointer
107 */
108 int i;
109 VMS_PROC_STUFF *vs;
110
111 /* Don't search the last one */
112 for (i=0, vs=procList; i<MAX_EVENT_FLAGS; i++, vs++)
113 {
114 if (vs->busy && vs->pid == pid)
115 return (vs);
116 }
117 return ((VMS_PROC_STUFF *)0);
118}
119
120start_vms_process_read (vs)
121 VMS_PROC_STUFF *vs;
122{
123 /*
124 Start an asynchronous read on a VMS process
125 We will catch up with the output sooner or later
126 */
127 int status;
128 int ProcAst ();
129
130 status = sys$qio (vs->eventFlag, vs->outputChan, IO$_READVBLK,
131 vs->iosb, 0, vs,
132 vs->inputBuffer, sizeof (vs->inputBuffer), 0, 0, 0, 0);
133 if (status != SS$_NORMAL)
134 return (0);
135 else
136 return (1);
137}
138
139extern int waiting_for_ast; /* in sysdep.c */
140extern int timer_ef;
141extern int input_ef;
142
143select (nDesc, rdsc, wdsc, edsc, timeOut)
144 int nDesc;
145 int *rdsc;
146 int *wdsc;
147 int *edsc;
148 int *timeOut;
149{
150 /* Emulate a select call
151
152 We know that we only use event flags 1-23
153
154 timeout == 100000 & bit 0 set means wait on keyboard input until
155 something shows up. If timeout == 0, we just read the event
156 flags and return what we find. */
157
158 int nfds = 0;
159 int status;
160 int time[2];
161 int delta = -10000000;
162 int zero = 0;
163 int timeout = *timeOut;
164 unsigned long mask, readMask, waitMask;
165
166 if (rdsc)
167 readMask = *rdsc << 1; /* Unix mask is shifted over 1 */
168 else
169 readMask = 0; /* Must be a wait call */
170
171 sys$clref (KEYBOARD_EVENT_FLAG);
172 sys$setast (0); /* Block interrupts */
173 sys$readef (KEYBOARD_EVENT_FLAG, &mask); /* See what is set */
174 mask &= readMask; /* Just examine what we need */
175 if (mask == 0)
176 { /* Nothing set, we must wait */
177 if (timeout != 0)
178 { /* Not just inspecting... */
179 if (!(timeout == 100000 &&
180 readMask == (1 << KEYBOARD_EVENT_FLAG)))
181 {
182 lib$emul (&timeout, &delta, &zero, time);
183 sys$setimr (TIMER_EVENT_FLAG, time, 0, 1);
184 waitMask = readMask | (1 << TIMER_EVENT_FLAG);
185 }
186 else
187 waitMask = readMask;
188 if (waitMask & (1 << KEYBOARD_EVENT_FLAG))
189 {
190 sys$clref (KEYBOARD_EVENT_FLAG);
191 waiting_for_ast = 1; /* Only if reading from 0 */
192 }
193 sys$setast (1);
194 sys$wflor (KEYBOARD_EVENT_FLAG, waitMask);
195 sys$cantim (1, 0);
196 sys$readef (KEYBOARD_EVENT_FLAG, &mask);
197 if (readMask & (1 << KEYBOARD_EVENT_FLAG))
198 waiting_for_ast = 0;
199 }
200 }
201 sys$setast (1);
202
203 /*
204 Count number of descriptors that are ready
205 */
206 mask &= readMask;
207 if (rdsc)
208 *rdsc = (mask >> 1); /* Back to Unix format */
209 for (nfds = 0; mask; mask >>= 1)
210 {
211 if (mask & 1)
212 nfds++;
213 }
214 return (nfds);
215}
216
217#define MAX_BUFF 1024
218
219write_to_vms_process (vs, buf, len)
220 VMS_PROC_STUFF *vs;
221 char *buf;
222 int len;
223{
224 /*
225 Write something to a VMS process.
226
227 We have to map newlines to carriage returns for VMS.
228 */
229 char ourBuff[MAX_BUFF];
230 short iosb[4];
231 int status;
232 int in, out;
233
234 while (len > 0)
235 {
236 out = map_nl_to_cr (buf, ourBuff, len, MAX_BUFF);
237 status = sys$qiow (0, vs->inputChan, IO$_WRITEVBLK|IO$M_NOFORMAT,
238 iosb, 0, 0, ourBuff, out, 0, 0, 0, 0);
239 if (status != SS$_NORMAL || (status = iosb[0]) != SS$_NORMAL)
240 {
241 error ("Could not write to subprocess: %x", status);
242 return (0);
243 }
244 len =- out;
245 }
246 return (1);
247}
248
249static
250map_nl_to_cr (in, out, maxIn, maxOut)
251 char *in;
252 char *out;
253 int maxIn;
254 int maxOut;
255{
256 /*
257 Copy `in' to `out' remapping `\n' to `\r'
258 */
259 int c;
260 int o;
261
262 for (o=0; maxIn-- > 0 && o < maxOut; o++)
263 {
264 c = *in++;
265 *out++ = (c == '\n') ? '\r' : c;
266 }
267 return (o);
268}
269
270clean_vms_buffer (buf, len)
271 char *buf;
272 int len;
273{
274 /*
275 Sanitize output from a VMS subprocess
276 Strip CR's and NULLs
277 */
278 char *oBuf = buf;
279 char c;
280 int l = 0;
281
282 while (len-- > 0)
283 {
284 c = *buf++;
285 if (c == '\r' || c == '\0')
286 ;
287 else
288 {
289 *oBuf++ = c;
290 l++;
291 }
292 }
293 return (l);
294}
295
296/*
297 For the CMU PTY driver
298*/
299#define PTYNAME "PYA0:"
300
301get_pty_channel (inDevName, outDevName, inChannel, outChannel)
302 char *inDevName;
303 char *outDevName;
304 int *inChannel;
305 int *outChannel;
306{
307 int PartnerUnitNumber;
308 int status;
309 struct {
310 int l;
311 char *a;
312 } d;
313 struct {
314 short BufLen;
315 short ItemCode;
316 int *BufAddress;
317 int *ItemLength;
318 } g[2];
319
320 d.l = strlen (PTYNAME);
321 d.a = PTYNAME;
322 *inChannel = 0; /* Should be `short' on VMS */
323 *outChannel = 0;
324 *inDevName = *outDevName = '\0';
325 status = sys$assign (&d, inChannel, 0, 0);
326 if (status == SS$_NORMAL)
327 {
328 *outChannel = *inChannel;
329 g[0].BufLen = sizeof (PartnerUnitNumber);
330 g[0].ItemCode = DVI$_UNIT;
331 g[0].BufAddress = &PartnerUnitNumber;
332 g[0].ItemLength = (int *)0;
333 g[1].BufLen = g[1].ItemCode = 0;
334 status = sys$getdviw (0, *inChannel, 0, &g, 0, 0, 0, 0);
335 if (status == SS$_NORMAL)
336 {
337 sprintf (inDevName, "_TPA%d:", PartnerUnitNumber);
338 strcpy (outDevName, inDevName);
339 }
340 }
341 return (status);
342}
343
344VMSgetwd (buf)
345 char *buf;
346{
347 /*
348 Return the current directory
349 */
350 char curdir[256];
351 char *getenv ();
352 char *s;
353 short len;
354 int status;
355 struct
356 {
357 int l;
358 char *a;
359 } d;
360
361 s = getenv ("SYS$DISK");
362 if (s)
363 strcpy (buf, s);
364 else
365 *buf = '\0';
366
367 d.l = 255;
368 d.a = curdir;
369 status = sys$setddir (0, &len, &d);
370 if (status & 1)
371 {
372 curdir[len] = '\0';
373 strcat (buf, curdir);
374 }
375}
376
377static
378call_process_ast (vs)
379 VMS_PROC_STUFF *vs;
380{
381 sys$setef (vs->eventFlag);
382}
383
384void
385child_setup (in, out, err, new_argv, env)
386 int in, out, err;
387 register char **new_argv;
388 char **env;
389{
390 /* ??? I suspect that maybe this shouldn't be done on VMS. */
391#ifdef subprocesses
392 /* Close Emacs's descriptors that this process should not have. */
393 close_process_descs ();
394#endif
395
396 if (XTYPE (current_buffer->directory) == Lisp_String)
397 chdir (XSTRING (current_buffer->directory)->data);
398}
399
400DEFUN ("call-process", Fcall_process, Scall_process, 1, MANY, 0,
401 "Call PROGRAM synchronously in a separate process.\n\
402Program's input comes from file INFILE (nil means null device, `NLA0:').\n\
403Insert output in BUFFER before point; t means current buffer;\n\
404 nil for BUFFER means discard it; 0 means discard and don't wait.\n\
405Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.\n\
406Remaining arguments are strings passed as command arguments to PROGRAM.\n\
407This function waits for PROGRAM to terminate, unless BUFFER is 0;\n\
408if you quit, the process is killed.")
409 (nargs, args)
410 int nargs;
411 register Lisp_Object *args;
412{
413 Lisp_Object display, buffer, path;
414 char oldDir[512];
415 int inchannel, outchannel;
416 int len;
417 int call_process_ast ();
418 struct
419 {
420 int l;
421 char *a;
422 } dcmd, din, dout;
423 char inDevName[65];
424 char outDevName[65];
425 short iosb[4];
426 int status;
427 int SpawnFlags = CLI$M_NOWAIT;
428 VMS_PROC_STUFF *vs;
429 VMS_PROC_STUFF *get_vms_process_stuff ();
430 int fd[2];
431 int filefd;
432 register int pid;
433 char buf[1024];
434 int count = specpdl_ptr - specpdl;
435 register unsigned char **new_argv;
436 struct buffer *old = current_buffer;
437
438 CHECK_STRING (args[0], 0);
439
440 if (nargs <= 1 || NULL (args[1]))
441 args[1] = build_string ("NLA0:");
442 else
443 args[1] = Fexpand_file_name (args[1], current_buffer->directory);
444
445 CHECK_STRING (args[1], 1);
446
447 {
448 register Lisp_Object tem;
449 buffer = tem = args[2];
450 if (nargs <= 2)
451 buffer = Qnil;
452 else if (!(EQ (tem, Qnil) || EQ (tem, Qt)
453 || XFASTINT (tem) == 0))
454 {
455 buffer = Fget_buffer (tem);
456 CHECK_BUFFER (buffer, 2);
457 }
458 }
459
460 display = nargs >= 3 ? args[3] : Qnil;
461
462 {
463 /*
464 if (args[0] == "*dcl*" then we need to skip pas the "-c",
465 else args[0] is the program to run.
466 */
467 register int i;
468 int arg0;
469 int firstArg;
470
471 if (strcmp (XSTRING (args[0])->data, "*dcl*") == 0)
472 {
473 arg0 = 5;
474 firstArg = 6;
475 }
476 else
477 {
478 arg0 = 0;
479 firstArg = 4;
480 }
481 len = XSTRING (args[arg0])->size + 1;
482 for (i = firstArg; i < nargs; i++)
483 {
484 CHECK_STRING (args[i], i);
485 len += XSTRING (args[i])->size + 1;
486 }
487 new_argv = alloca (len);
488 strcpy (new_argv, XSTRING (args[arg0])->data);
489 for (i = firstArg; i < nargs; i++)
490 {
491 strcat (new_argv, " ");
492 strcat (new_argv, XSTRING (args[i])->data);
493 }
494 dcmd.l = len-1;
495 dcmd.a = new_argv;
496
497 status = get_pty_channel (inDevName, outDevName, &inchannel, &outchannel);
498 if (!(status & 1))
499 error ("Error getting PTY channel: %x", status);
500 if (XTYPE (buffer) == Lisp_Int)
501 {
502 dout.l = strlen ("NLA0:");
503 dout.a = "NLA0:";
504 }
505 else
506 {
507 dout.l = strlen (outDevName);
508 dout.a = outDevName;
509 }
510
511 vs = get_vms_process_stuff ();
512 if (!vs)
513 {
514 sys$dassgn (inchannel);
515 sys$dassgn (outchannel);
516 error ("Too many VMS processes");
517 }
518 vs->inputChan = inchannel;
519 vs->outputChan = outchannel;
520 }
521
522 filefd = open (XSTRING (args[1])->data, O_RDONLY, 0);
523 if (filefd < 0)
524 {
525 sys$dassgn (inchannel);
526 sys$dassgn (outchannel);
527 give_back_vms_process_stuff (vs);
528 report_file_error ("Opening process input file", Fcons (args[1], Qnil));
529 }
530 else
531 close (filefd);
532
533 din.l = XSTRING (args[1])->size;
534 din.a = XSTRING (args[1])->data;
535
536 /*
537 Start a read on the process channel
538 */
539 if (XTYPE (buffer) != Lisp_Int)
540 {
541 start_vms_process_read (vs);
542 SpawnFlags = CLI$M_NOWAIT;
543 }
544 else
545 SpawnFlags = 0;
546
547 /*
548 On VMS we need to change the current directory
549 of the parent process before forking so that
550 the child inherit that directory. We remember
551 where we were before changing.
552 */
553 VMSgetwd (oldDir);
554 child_setup (0, 0, 0, 0, 0);
555 status = lib$spawn (&dcmd, &din, &dout, &SpawnFlags, 0, &vs->pid,
556 &vs->exitStatus, 0, call_process_ast, vs);
557 chdir (oldDir);
558
559 if (status != SS$_NORMAL)
560 {
561 sys$dassgn (inchannel);
562 sys$dassgn (outchannel);
563 give_back_vms_process_stuff (vs);
564 error ("Error calling LIB$SPAWN: %x", status);
565 }
566 pid = vs->pid;
567
568 if (XTYPE (buffer) == Lisp_Int)
569 {
570#ifndef subprocesses
571 wait_without_blocking ();
572#endif subprocesses
573 return Qnil;
574 }
575
576 record_unwind_protect (call_process_cleanup,
577 Fcons (make_number (fd[0]), make_number (pid)));
578
579
580 if (XTYPE (buffer) == Lisp_Buffer)
581 Fset_buffer (buffer);
582
583 immediate_quit = 1;
584 QUIT;
585
586 while (1)
587 {
588 sys$waitfr (vs->eventFlag);
589 if (vs->iosb[0] & 1)
590 {
591 immediate_quit = 0;
592 if (!NULL (buffer))
593 {
594 vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]);
595 InsCStr (vs->inputBuffer, vs->iosb[1]);
596 }
597 if (!NULL (display) && INTERACTIVE)
598 redisplay_preserve_echo_area ();
599 immediate_quit = 1;
600 QUIT;
601 if (!start_vms_process_read (vs))
602 break; /* The other side went away */
603 }
604 else
605 break;
606 }
607 sys$dassgn (inchannel);
608 sys$dassgn (outchannel);
609 give_back_vms_process_stuff (vs);
610
611 /* Wait for it to terminate, unless it already has. */
612 wait_for_termination (pid);
613
614 immediate_quit = 0;
615
616 set_current_buffer (old);
617
618 unbind_to (count);
619
620 return Qnil;
621}
622
623create_process (process, new_argv)
624 Lisp_Object process;
625 char *new_argv;
626{
627 int pid, inchannel, outchannel, forkin, forkout;
628 char old_dir[512];
629 char in_dev_name[65];
630 char out_dev_name[65];
631 short iosb[4];
632 int status;
633 int spawn_flags = CLI$M_NOWAIT;
634 int child_sig ();
635 struct {
636 int l;
637 char *a;
638 } din, dout, dprompt, dcmd;
639 VMS_PROC_STUFF *vs;
640 VMS_PROC_STUFF *get_vms_process_stuff ();
641
642 status = get_pty_channel (in_dev_name, out_dev_name, &inchannel, &outchannel);
643 if (!(status & 1))
644 {
645 remove_process (process);
646 error ("Error getting PTY channel: %x", status);
647 }
648 dout.l = strlen (out_dev_name);
649 dout.a = out_dev_name;
650 dprompt.l = strlen (DCL_PROMPT);
651 dprompt.a = DCL_PROMPT;
652
653 if (strcmp (new_argv, "*dcl*") == 0)
654 {
655 din.l = strlen (in_dev_name);
656 din.a = in_dev_name;
657 dcmd.l = 0;
658 dcmd.a = (char *)0;
659 }
660 else
661 {
662 din.l = strlen ("NLA0:");
663 din.a = "NLA0:";
664 dcmd.l = strlen (new_argv);
665 dcmd.a = new_argv;
666 }
667
668 /* Delay interrupts until we have a chance to store
669 the new fork's pid in its process structure */
670 sys$setast (0);
671
672 vs = get_vms_process_stuff ();
673 if (vs == 0)
674 {
675 sys$setast (1);
676 remove_process (process);
677 error ("Too many VMS processes");
678 }
679 vs->inputChan = inchannel;
680 vs->outputChan = outchannel;
681
682 /* Start a read on the process channel */
683 start_vms_process_read (vs);
684
685 /* Switch current directory so that the child inherits it. */
686 VMSgetwd (old_dir);
687 child_setup (0, 0, 0, 0, 0);
688
689 status = lib$spawn (&dcmd, &din, &dout, &spawn_flags, 0, &vs->pid,
690 &vs->exitStatus, 0, child_sig, vs, &dprompt);
691 chdir (old_dir);
692
693 if (status != SS$_NORMAL)
694 {
695 sys$setast (1);
696 remove_process (process);
697 error ("Error calling LIB$SPAWN: %x", status);
698 }
699 vs->pid &= 0xffff; /* It needs to fit in a FASTINT,
700 we don't need the rest of the bits */
701 pid = vs->pid;
702
703 /*
704 ON VMS process->infd holds the (event flag-1)
705 that we use for doing I/O on that process.
706 `input_wait_mask' is the cluster of event flags
707 we can wait on.
708
709 Event flags returned start at 1 for the keyboard.
710 Since Unix expects descriptor 0 for the keyboard,
711 we substract one from the event flag.
712 */
713 inchannel = vs->eventFlag-1;
714
715 /* Record this as an active process, with its channels.
716 As a result, child_setup will close Emacs's side of the pipes. */
717 chan_process[inchannel] = process;
718 XFASTINT (XPROCESS (process)->infd) = inchannel;
719 XFASTINT (XPROCESS (process)->outfd) = outchannel;
720 XFASTINT (XPROCESS (process)->flags) = RUNNING;
721
722 /* Delay interrupts until we have a chance to store
723 the new fork's pid in its process structure */
724
725#define NO_ECHO "set term/noecho\r"
726 sys$setast (0);
727 /*
728 Send a command to the process to not echo input
729
730 The CMU PTY driver does not support SETMODEs.
731 */
732 write_to_vms_process (vs, NO_ECHO, strlen (NO_ECHO));
733
734 XFASTINT (XPROCESS (process)->pid) = pid;
735 sys$setast (1);
736}
737
738child_sig (vs)
739 VMS_PROC_STUFF *vs;
740{
741 register int pid;
742 Lisp_Object tail, proc;
743 register struct Lisp_Process *p;
744 int old_errno = errno;
745
746 pid = vs->pid;
747 sys$setef (vs->eventFlag);
748
749 for (tail = Vprocess_alist; XSYMBOL (tail) != XSYMBOL (Qnil); tail = XCONS (tail)->cdr)
750 {
751 proc = XCONS (XCONS (tail)->car)->cdr;
752 p = XPROCESS (proc);
753 if (EQ (p->childp, Qt) && XFASTINT (p->pid) == pid)
754 break;
755 }
756
757 if (XSYMBOL (tail) == XSYMBOL (Qnil))
758 return;
759
760 child_changed++;
761 XFASTINT (p->flags) = EXITED | CHANGED;
762 /* Truncate the exit status to 24 bits so that it fits in a FASTINT */
763 XFASTINT (p->reason) = (vs->exitStatus) & 0xffffff;
764}
765
766syms_of_vmsproc ()
767{
768 defsubr (&Scall_process);
769}
770
771init_vmsproc ()
772{
773 char *malloc ();
774 int i;
775 VMS_PROC_STUFF *vs;
776
777 for (vs=procList, i=0; i<MAX_EVENT_FLAGS+1; i++, vs++)
778 {
779 vs->busy = 0;
780 vs->eventFlag = i;
781 sys$clref (i);
782 vs->inputChan = 0;
783 vs->pid = 0;
784 }
785 procList[0].busy = 1; /* Zero is reserved */
786}
diff --git a/src/xmenu.c b/src/xmenu.c
new file mode 100644
index 00000000000..553e5b35a7a
--- /dev/null
+++ b/src/xmenu.c
@@ -0,0 +1,378 @@
1/* X Communication module for terminals which understand the X protocol.
2 Copyright (C) 1986, 1988 Free Software Foundation, Inc.
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 1, or (at your option)
9any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs; see the file COPYING. If not, write to
18the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
19
20/* X pop-up deck-of-cards menu facility for gnuemacs.
21 *
22 * Written by Jon Arnold and Roman Budzianowski
23 * Mods and rewrite by Robert Krawitz
24 *
25 */
26
27/* $Source: /u2/third_party/gnuemacs.chow/src/RCS/xmenu.c,v $
28 * $Author: rlk $
29 * $Locker: $
30 * $Header: xmenu.c,v 1.6 86/08/26 17:23:26 rlk Exp $
31 *
32 */
33
34#ifndef lint
35static char *rcsid_GXMenu_c = "$Header: xmenu.c,v 1.6 86/08/26 17:23:26 rlk Exp $";
36#endif lint
37#ifdef XDEBUG
38#include <stdio.h>
39#endif
40
41/* On 4.3 this loses if it comes after xterm.h. */
42#include <signal.h>
43#include "config.h"
44#include "lisp.h"
45#include "screen.h"
46#include "window.h"
47
48/* This may include sys/types.h, and that somehow loses
49 if this is not done before the other system files. */
50#include "xterm.h"
51
52/* Load sys/types.h if not already loaded.
53 In some systems loading it twice is suicidal. */
54#ifndef makedev
55#include <sys/types.h>
56#endif
57
58#include "dispextern.h"
59
60#ifdef HAVE_X11
61#include "../oldXMenu/XMenu.h"
62#else
63#include <X/XMenu.h>
64#endif
65
66#define min(x,y) (((x) < (y)) ? (x) : (y))
67#define max(x,y) (((x) > (y)) ? (x) : (y))
68
69#define NUL 0
70
71#ifndef TRUE
72#define TRUE 1
73#define FALSE 0
74#endif TRUE
75
76#ifdef HAVE_X11
77extern Display *x_current_display;
78#else
79#define ButtonReleaseMask ButtonReleased
80#endif /* not HAVE_X11 */
81
82Lisp_Object xmenu_show ();
83extern int x_error_handler ();
84
85/*************************************************************/
86
87#if 0
88/* Ignoring the args is easiest. */
89xmenu_quit ()
90{
91 error ("Unknown XMenu error");
92}
93#endif
94
95DEFUN ("x-popup-menu",Fx_popup_menu, Sx_popup_menu, 1, 2, 0,
96 "Pop up a deck-of-cards menu and return user's selection.\n\
97ARG is a position specification: a list ((XOFFSET YOFFSET) WINDOW)\n\
98where XOFFSET and YOFFSET are positions in characters from the top left\n\
99corner of WINDOW's screen. A mouse-event list will serve for this.\n\
100This controls the position of the center of the first line\n\
101in the first pane of the menu, not the top left of the menu as a whole.\n\
102\n\
103MENU is a specifier for a menu. It is a list of the form\n\
104\(TITLE PANE1 PANE2...), and each pane is a list of form\n\
105\(TITLE (LINE ITEM)...). Each line should be a string, and item should\n\
106be the return value for that line (i.e. if it is selected.")
107 (arg, menu)
108 Lisp_Object arg, menu;
109{
110 int number_of_panes;
111 Lisp_Object XMenu_return;
112 int XMenu_xpos, XMenu_ypos;
113 char **menus;
114 char ***names;
115 Lisp_Object **obj_list;
116 int *items;
117 char *title;
118 char *error_name;
119 Lisp_Object ltitle, selection;
120 int i, j;
121 SCREEN_PTR s;
122 Lisp_Object x, y, window;
123
124 window = Fcar (Fcdr (arg));
125 x = Fcar (Fcar (arg));
126 y = Fcar (Fcdr (Fcar (arg)));
127 CHECK_WINDOW (window, 0);
128 CHECK_NUMBER (x, 0);
129 CHECK_NUMBER (y, 0);
130 s = XSCREEN (WINDOW_SCREEN (XWINDOW (window)));
131
132 XMenu_xpos = FONT_WIDTH (s->display.x->font) * XINT (x);
133 XMenu_ypos = FONT_HEIGHT (s->display.x->font) * XINT (y);
134 XMenu_xpos += s->display.x->left_pos;
135 XMenu_ypos += s->display.x->top_pos;
136
137 ltitle = Fcar (menu);
138 CHECK_STRING (ltitle, 1);
139 title = (char *) XSTRING (ltitle)->data;
140 number_of_panes=list_of_panes (&obj_list, &menus, &names, &items, Fcdr (menu));
141#ifdef XDEBUG
142 fprintf (stderr, "Panes= %d\n", number_of_panes);
143 for (i=0; i < number_of_panes; i++)
144 {
145 fprintf (stderr, "Pane %d lines %d title %s\n", i, items[i], menus[i]);
146 for (j=0; j < items[i]; j++)
147 {
148 fprintf (stderr, " Item %d %s\n", j, names[i][j]);
149 }
150 }
151#endif
152 BLOCK_INPUT;
153 selection = xmenu_show (ROOT_WINDOW, XMenu_xpos, XMenu_ypos, names, menus,
154 items, number_of_panes, obj_list, title, &error_name);
155 UNBLOCK_INPUT;
156 /** fprintf (stderr, "selection = %x\n", selection); **/
157 if (selection != NUL)
158 { /* selected something */
159 XMenu_return = selection;
160 }
161 else
162 { /* nothing selected */
163 XMenu_return = Qnil;
164 }
165 /* now free up the strings */
166 for (i=0; i < number_of_panes; i++)
167 {
168 free (names[i]);
169 free (obj_list[i]);
170 }
171 free (menus);
172 free (obj_list);
173 free (names);
174 free (items);
175 /* free (title); */
176 if (error_name) error (error_name);
177 return XMenu_return;
178}
179
180struct indices {
181 int pane;
182 int line;
183};
184
185Lisp_Object
186xmenu_show (parent, startx, starty, line_list, pane_list, line_cnt,
187 pane_cnt, item_list, title, error)
188 Window parent;
189 int startx, starty; /* upper left corner position BROKEN */
190 char **line_list[]; /* list of strings for items */
191 char *pane_list[]; /* list of pane titles */
192 char *title;
193 int pane_cnt; /* total number of panes */
194 Lisp_Object *item_list[]; /* All items */
195 int line_cnt[]; /* Lines in each pane */
196 char **error; /* Error returned */
197{
198 XMenu *GXMenu;
199 int last, panes, selidx, lpane, status;
200 int lines, sofar;
201 Lisp_Object entry;
202 /* struct indices *datap, *datap_save; */
203 char *datap;
204 int ulx, uly, width, height;
205 int dispwidth, dispheight;
206
207 *error = (char *) 0; /* Initialize error pointer to null */
208 GXMenu = XMenuCreate (XDISPLAY parent, "emacs");
209 if (GXMenu == NUL)
210 {
211 *error = "Can't create menu";
212 return (0);
213 }
214
215 for (panes=0, lines=0; panes < pane_cnt; lines += line_cnt[panes], panes++)
216 ;
217 /* datap = (struct indices *) xmalloc (lines * sizeof (struct indices)); */
218 /*datap = (char *) xmalloc (lines * sizeof (char));
219 datap_save = datap;*/
220
221 for (panes = 0, sofar=0;panes < pane_cnt;sofar +=line_cnt[panes], panes++)
222 {
223 /* create all the necessary panes */
224 lpane = XMenuAddPane (XDISPLAY GXMenu, pane_list[panes], TRUE);
225 if (lpane == XM_FAILURE)
226 {
227 XMenuDestroy (XDISPLAY GXMenu);
228 *error = "Can't create pane";
229 return (0);
230 }
231 for (selidx = 0; selidx < line_cnt[panes] ; selidx++)
232 {
233 /* add the selection stuff to the menus */
234 /* datap[selidx+sofar].pane = panes;
235 datap[selidx+sofar].line = selidx; */
236 if (XMenuAddSelection (XDISPLAY GXMenu, lpane, 0,
237 line_list[panes][selidx], TRUE)
238 == XM_FAILURE)
239 {
240 XMenuDestroy (XDISPLAY GXMenu);
241 /* free (datap); */
242 *error = "Can't add selection to menu";
243 /* error ("Can't add selection to menu"); */
244 return (0);
245 }
246 }
247 }
248 /* all set and ready to fly */
249 XMenuRecompute (XDISPLAY GXMenu);
250 dispwidth = DisplayWidth (x_current_display, XDefaultScreen (x_current_display));
251 dispheight = DisplayHeight (x_current_display, XDefaultScreen (x_current_display));
252 startx = min (startx, dispwidth);
253 starty = min (starty, dispheight);
254 startx = max (startx, 1);
255 starty = max (starty, 1);
256 XMenuLocate (XDISPLAY GXMenu, 0, 0, startx, starty,
257 &ulx, &uly, &width, &height);
258 if (ulx+width > dispwidth)
259 {
260 startx -= (ulx + width) - dispwidth;
261 ulx = dispwidth - width;
262 }
263 if (uly+height > dispheight)
264 {
265 starty -= (uly + height) - dispheight;
266 uly = dispheight - height;
267 }
268 if (ulx < 0) startx -= ulx;
269 if (uly < 0) starty -= uly;
270
271 XMenuSetFreeze (GXMenu, TRUE);
272 panes = selidx = 0;
273
274 status = XMenuActivate (XDISPLAY GXMenu, &panes, &selidx,
275 startx, starty, ButtonReleaseMask, &datap);
276 switch (status)
277 {
278 case XM_SUCCESS:
279#ifdef XDEBUG
280 fprintf (stderr, "pane= %d line = %d\n", panes, selidx);
281#endif
282 entry = item_list[panes][selidx];
283 break;
284 case XM_FAILURE:
285 /*free (datap_save); */
286 XMenuDestroy (XDISPLAY GXMenu);
287 *error = "Can't activate menu";
288 /* error ("Can't activate menu"); */
289 case XM_IA_SELECT:
290 case XM_NO_SELECT:
291 entry = Qnil;
292 break;
293 }
294 XMenuDestroy (XDISPLAY GXMenu);
295 /*free (datap_save);*/
296 return (entry);
297}
298
299syms_of_xmenu ()
300{
301 defsubr (&Sx_popup_menu);
302}
303
304list_of_panes (vector, panes, names, items, menu)
305 Lisp_Object ***vector; /* RETURN all menu objects */
306 char ***panes; /* RETURN pane names */
307 char ****names; /* RETURN all line names */
308 int **items; /* RETURN number of items per pane */
309 Lisp_Object menu;
310{
311 Lisp_Object tail, item, item1;
312 int i;
313
314 if (XTYPE (menu) != Lisp_Cons) menu = wrong_type_argument (Qlistp, menu);
315
316 i= XFASTINT (Flength (menu, 1));
317
318 *vector = (Lisp_Object **) xmalloc (i * sizeof (Lisp_Object *));
319 *panes = (char **) xmalloc (i * sizeof (char *));
320 *items = (int *) xmalloc (i * sizeof (int));
321 *names = (char ***) xmalloc (i * sizeof (char **));
322
323 for (i=0, tail = menu; !NULL (tail); tail = Fcdr (tail), i++)
324 {
325 item = Fcdr (Fcar (tail));
326 if (XTYPE (item) != Lisp_Cons) (void) wrong_type_argument (Qlistp, item);
327#ifdef XDEBUG
328 fprintf (stderr, "list_of_panes check tail, i=%d\n", i);
329#endif
330 item1 = Fcar (Fcar (tail));
331 CHECK_STRING (item1, 1);
332#ifdef XDEBUG
333 fprintf (stderr, "list_of_panes check pane, i=%d%s\n", i,
334 XSTRING (item1)->data);
335#endif
336 (*panes)[i] = (char *) XSTRING (item1)->data;
337 (*items)[i] = list_of_items ((*vector)+i, (*names)+i, item);
338 /* (*panes)[i] = (char *) xmalloc ((XSTRING (item1)->size)+1);
339 bcopy (XSTRING (item1)->data, (*panes)[i], XSTRING (item1)->size + 1)
340 ; */
341 }
342 return i;
343}
344
345
346list_of_items (vector, names, pane) /* get list from emacs and put to vector */
347 Lisp_Object **vector; /* RETURN menu "objects" */
348 char ***names; /* RETURN line names */
349 Lisp_Object pane;
350{
351 Lisp_Object tail, item, item1;
352 int i;
353
354 if (XTYPE (pane) != Lisp_Cons) pane = wrong_type_argument (Qlistp, pane);
355
356 i= XFASTINT (Flength (pane, 1));
357
358 *vector = (Lisp_Object *) xmalloc (i * sizeof (Lisp_Object));
359 *names = (char **) xmalloc (i * sizeof (char *));
360
361 for (i=0, tail = pane; !NULL (tail); tail = Fcdr (tail), i++)
362 {
363 item = Fcar (tail);
364 if (XTYPE (item) != Lisp_Cons) (void) wrong_type_argument (Qlistp, item);
365#ifdef XDEBUG
366 fprintf (stderr, "list_of_items check tail, i=%d\n", i);
367#endif
368 (*vector)[i] = Fcdr (item);
369 item1 = Fcar (item);
370 CHECK_STRING (item1, 1);
371#ifdef XDEBUG
372 fprintf (stderr, "list_of_items check item, i=%d%s\n", i,
373 XSTRING (item1)->data);
374#endif
375 (*names)[i] = (char *) XSTRING (item1)->data;
376 }
377 return i;
378}
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-17 17:27:43 +0000