aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog4
-rw-r--r--src/unexencap.c116
-rw-r--r--src/unexfx2800.c16
-rw-r--r--src/vms-pp.c243
-rw-r--r--src/vms-pp.trans10
-rw-r--r--src/vms-pwd.h35
-rw-r--r--src/vmsdir.h98
-rw-r--r--src/vmsfns.c962
-rw-r--r--src/vmsgmalloc.c2012
-rw-r--r--src/vmsmap.c225
-rw-r--r--src/vmspaths.h32
-rw-r--r--src/vmsproc.c795
-rw-r--r--src/vmsproc.h21
-rw-r--r--src/vmstime.c377
-rw-r--r--src/vmstime.h35
15 files changed, 4 insertions, 4977 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 59630f5b615..0e111f99bae 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,9 @@
12001-02-22 Gerd Moellmann <gerd@gnu.org> 12001-02-22 Gerd Moellmann <gerd@gnu.org>
2 2
3 * vms-pp.c, vmsdir.h, vmsmap.c, vmsproc.h, vms-pp.trans, vmsfns.c,
4 * vmspaths.h, vmstime.c, vms-pwd.h, vmsgmalloc.c, vmsproc.c,
5 * vmstime.h: Files removed.
6
3 * unexencap.c, unexfx2800.c: Files removed. 7 * unexencap.c, unexfx2800.c: Files removed.
4 8
5 * dispnew.c (direct_output_for_insert): Give up if we are showing 9 * dispnew.c (direct_output_for_insert): Give up if we are showing
diff --git a/src/unexencap.c b/src/unexencap.c
deleted file mode 100644
index 4ffc41145a9..00000000000
--- a/src/unexencap.c
+++ /dev/null
@@ -1,116 +0,0 @@
1/* Waiting for papers! */
2
3/*
4 * Do an unexec() for coff encapsulation. Uses the approach I took
5 * for AKCL, so don't be surprised if it doesn't look too much like
6 * the other unexec() routines. Assumes NO_REMAP. Should be easy to
7 * adapt to the emacs style unexec() if that is desired, but this works
8 * just fine for me with GCC/GAS/GLD under System V. - Jordan
9 */
10
11#include <sys/types.h>
12#include <sys/fcntl.h>
13#include <sys/file.h>
14#include <stdio.h>
15#include "/usr/gnu/lib/gcc/gcc-include/a.out.h"
16
17filecpy(to, from, n)
18FILE *to, *from;
19register int n;
20{
21 char buffer[BUFSIZ];
22
23 for (;;)
24 if (n > BUFSIZ) {
25 fread(buffer, BUFSIZ, 1, from);
26 fwrite(buffer, BUFSIZ, 1, to);
27 n -= BUFSIZ;
28 } else if (n > 0) {
29 fread(buffer, 1, n, from);
30 fwrite(buffer, 1, n, to);
31 break;
32 } else
33 break;
34}
35/* ****************************************************************
36 * unexec
37 *
38 * driving logic.
39 * ****************************************************************/
40unexec (new_name, a_name, data_start, bss_start, entry_address)
41char *new_name, *a_name;
42unsigned data_start, bss_start, entry_address;
43{
44 struct coffheader header1;
45 struct coffscn *tp, *dp, *bp;
46 struct exec header;
47 int stsize;
48 char *original_file = a_name;
49 char *save_file = new_name;
50
51 char *data_begin, *data_end;
52 int original_data;
53 FILE *original, *save;
54 register int n;
55 register char *p;
56 extern char *sbrk();
57 char stdin_buf[BUFSIZ], stdout_buf[BUFSIZ];
58
59
60 fclose(stdin);
61 original = fopen(original_file, "r");
62 if (stdin != original || original->_file != 0) {
63 fprintf(stderr, "unexec: Can't open the original file.\n");
64 exit(1);
65 }
66 setbuf(original, stdin_buf);
67 fclose(stdout);
68 unlink(save_file);
69 n = open(save_file, O_CREAT|O_WRONLY, 0777);
70 if (n != 1 || (save = fdopen(n, "w")) != stdout) {
71 fprintf(stderr, "unexec: Can't open the save file.\n");
72 exit(1);
73 }
74 setbuf(save, stdout_buf);
75
76 fread(&header1, sizeof(header1), 1, original);
77 tp = &header1.scns[0];
78 dp = &header1.scns[1];
79 bp = &header1.scns[2];
80 fread(&header, sizeof(header), 1, original);
81 data_begin=(char *)N_DATADDR(header);
82 data_end = sbrk(0);
83 original_data = header.a_data;
84 header.a_data = data_end - data_begin;
85 header.a_bss = 0;
86 dp->s_size = header.a_data;
87 bp->s_paddr = dp->s_vaddr + dp->s_size;
88 bp->s_vaddr = bp->s_paddr;
89 bp->s_size = 0;
90 header1.tsize = tp->s_size;
91 header1.dsize = dp->s_size;
92 header1.bsize = bp->s_size;
93 fwrite(&header1, sizeof(header1), 1, save);
94 fwrite(&header, sizeof(header), 1, save);
95
96 filecpy(save, original, header.a_text);
97
98 for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ)
99 if (n > BUFSIZ)
100 fwrite(p, BUFSIZ, 1, save);
101 else if (n > 0) {
102 fwrite(p, 1, n, save);
103 break;
104 } else
105 break;
106
107 fseek(original, original_data, 1);
108
109 filecpy(save, original, header.a_syms+header.a_trsize+header.a_drsize);
110 fread(&stsize, sizeof(stsize), 1, original);
111 fwrite(&stsize, sizeof(stsize), 1, save);
112 filecpy(save, original, stsize - sizeof(stsize));
113
114 fclose(original);
115 fclose(save);
116}
diff --git a/src/unexfx2800.c b/src/unexfx2800.c
deleted file mode 100644
index 89e14e678d8..00000000000
--- a/src/unexfx2800.c
+++ /dev/null
@@ -1,16 +0,0 @@
1/* Unexec for the Alliant FX/2800. */
2
3#include <stdio.h>
4
5unexec (new_name, a_name, data_start, bss_start, entry_address)
6 char *new_name, *a_name;
7 unsigned data_start, bss_start, entry_address;
8{
9 int stat;
10
11 stat = elf_write_modified_data (a_name, new_name);
12 if (stat < 0)
13 perror ("emacs: elf_write_modified_data");
14 else if (stat > 0)
15 fprintf (stderr, "Unspecified error from elf_write_modified_data.\n");
16}
diff --git a/src/vms-pp.c b/src/vms-pp.c
deleted file mode 100644
index 9ac7a4966a9..00000000000
--- a/src/vms-pp.c
+++ /dev/null
@@ -1,243 +0,0 @@
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 2, 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, Inc., 59 Temple Place - Suite 330,
20Boston, MA 02111-1307, USA.
21
22 *
23 * Usage:
24 * vms_pp infile outfile
25 * implicit inputs:
26 * The file "vms_pp.trans" has the names and their translations.
27 * description:
28 * Vms_pp takes the input file and scans it, replacing the long
29 * names with shorter names according to the table read in from
30 * vms_pp.trans. The line is then written to the output file.
31 *
32 * Additionally, the "#undef foo" construct is replaced with:
33 * #ifdef foo
34 * #undef foo
35 * #endif
36 *
37 * The construct #if defined(foo) is replaced with
38 * #ifdef foo
39 * #define foo_VAL 1
40 * #else
41 * #define foo_VAL 0
42 * #endif
43 * #define defined(XX) XX_val
44 * #if defined(foo)
45 *
46 * This last construction only works on single line #if's and takes
47 * advantage of a questionable C pre-processor trick. If there are
48 * comments within the #if, that contain "defined", then this will
49 * bomb.
50 */
51#include <stdio.h>
52
53#define Max_table 100
54#define Table_name "vms_pp.trans"
55#define Word_member \
56"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$"
57
58static FILE *in,*out; /* read from, write to */
59struct item { /* symbol table entries */
60 char *name;
61 char *value;
62};
63static struct item name_table[Max_table]; /* symbol table */
64static int defined_defined = 0; /* small optimization */
65
66main(argc,argv) int argc; char **argv; {
67 char buffer[1024];
68
69 if(argc != 3) { /* check argument count */
70 fprintf(stderr,"usage: vms_pp infile outfile");
71 exit();
72 }
73 init_table(); /* read in translation table */
74
75/* open input and output files
76 */
77 if((in = fopen(argv[1],"r")) == NULL) {
78 fprintf(stderr,"vms_pp: unable to open file '%s'",argv[1]);
79 exit();
80 }
81 if((out = fopen(argv[2],"w")) == NULL) {
82 fprintf(stderr,"vms_pp: unable to create file '%s'",argv[2]);
83 exit();
84 }
85
86 while(fgets(buffer,1023,in) != NULL) { /* loop through buffer until end */
87 process_line(buffer); /* process the line */
88 fputs(buffer,out); /* write out the line */
89 }
90}
91
92/* buy - allocate and copy a string
93 */
94static char *buy(str) char *str; {
95 char *temp;
96
97 if(!(temp = malloc(strlen(str)+1))) {
98 fprintf(stderr,"vms_pp: can't allocate memory");
99 exit();
100 }
101 strcpy(temp,str);
102 return temp;
103}
104
105/* gather_word - return a buffer full of the next word
106 */
107static char *gather_word(ptr,word) char *ptr, *word;{
108 for(; strchr(Word_member,*ptr); ptr++,word++)
109 *word = *ptr;
110 *word = 0;
111 return ptr;
112}
113
114/* skip_white - skip white space
115 */
116static char *skip_white(ptr) char *ptr; {
117 while(*ptr == ' ' || *ptr == '\t')
118 ptr++;
119 return ptr;
120}
121
122/* init_table - initialize translation table.
123 */
124init_table() {
125 char buf[256],*ptr,word[128];
126 FILE *in;
127 int i;
128
129 if((in = fopen(Table_name,"r")) == NULL) { /* open file */
130 fprintf(stderr,"vms_pp: can't open '%s'",Table_name);
131 exit();
132 }
133 for(i = 0; fgets(buf,255,in) != NULL;) { /* loop through lines */
134 ptr = skip_white(buf);
135 if(*ptr == '!') /* skip comments */
136 continue;
137 ptr = gather_word(ptr,word); /* get long word */
138 if(*word == 0) { /* bad entry */
139 fprintf(stderr,"vms_pp: bad input line '%s'\n",buf);
140 continue;
141 }
142 name_table[i].name = buy(word); /* set up the name */
143 ptr = skip_white(ptr); /* skip white space */
144 ptr = gather_word(ptr,word); /* get equivalent name */
145 if(*word == 0) { /* bad entry */
146 fprintf(stderr,"vms_pp: bad input line '%s'\n",buf);
147 continue;
148 }
149 name_table[i].value = buy(word); /* and the equivalent name */
150 i++; /* increment to next position */
151 }
152 for(; i < Max_table; i++) /* mark rest as unused */
153 name_table[i].name = 0;
154}
155
156/* process_line - do actual line processing
157 */
158process_line(buf) char *buf; {
159 char *in_ptr,*out_ptr;
160 char word[128],*ptr;
161 int len;
162
163 check_pp(buf); /* check for preprocessor lines */
164
165 for(in_ptr = out_ptr = buf; *in_ptr;) {
166 if(!strchr(Word_member,*in_ptr)) /* non alpha-numeric? just copy */
167 *out_ptr++ = *in_ptr++;
168 else {
169 in_ptr = gather_word(in_ptr,word); /* get the 'word' */
170 if(strlen(word) > 31) /* length is too long */
171 replace_word(word); /* replace the word */
172 for(ptr = word; *ptr; ptr++,out_ptr++) /* copy out the word */
173 *out_ptr = *ptr;
174 }
175 }
176 *out_ptr = 0;
177}
178
179/* check_pp - check for preprocessor lines
180 */
181check_pp(buf) char *buf; {
182 char *ptr,*p;
183 char word[128];
184
185 ptr = skip_white(buf); /* skip white space */
186 if(*ptr != '#') /* is this a preprocessor line? */
187 return; /* no, just return */
188
189 ptr = skip_white(++ptr); /* skip white */
190 ptr = gather_word(ptr,word); /* get command word */
191 if(!strcmp("undef",word)) { /* undef? */
192 ptr = skip_white(ptr);
193 ptr = gather_word(ptr,word); /* get the symbol to undef */
194 fprintf(out,"#ifdef %s\n",word);
195 fputs(buf,out);
196 strcpy(buf,"#endif");
197 return;
198 }
199 if(!strcmp("if",word)) { /* check for if */
200 for(;;) {
201 ptr = strchr(ptr,'d'); /* look for d in defined */
202 if(!ptr) /* are we done? */
203 return;
204 if(strchr(Word_member,*(ptr-1))){ /* at beginning of word? */
205 ptr++; continue; /* no, continue looking */
206 }
207 ptr = gather_word(ptr,word); /* get the word */
208 if(strcmp(word,"defined")) /* skip if not defined */
209 continue;
210 ptr = skip_white(ptr); /* skip white */
211 if(*ptr != '(') /* look for open paren */
212 continue; /* error, continue */
213 ptr++; /* skip paren */
214 ptr = skip_white(ptr); /* more white skipping */
215 ptr = gather_word(ptr,word); /* get the thing to test */
216 if(!*word) /* null word is bad */
217 continue;
218 fprintf(out,"#ifdef %s\n",word); /* generate the code */
219 fprintf(out,"#define %s_VAL 1\n",word);
220 fprintf(out,"#else\n");
221 fprintf(out,"#define %s_VAL 0\n",word);
222 fprintf(out,"#endif\n");
223 if(!defined_defined) {
224 fprintf(out,"#define defined(XXX) XXX/**/_VAL\n");
225 defined_defined = 1;
226 }
227 }
228 }
229}
230
231/* replace_word - look the word up in the table, and replace it
232 * if a match is found.
233 */
234replace_word(word) char *word; {
235 int i;
236
237 for(i = 0; i < Max_table && name_table[i].name; i++)
238 if(!strcmp(word,name_table[i].name)) {
239 strcpy(word,name_table[i].value);
240 return;
241 }
242 fprintf(stderr,"couldn't find '%s'\n",word);
243}
diff --git a/src/vms-pp.trans b/src/vms-pp.trans
deleted file mode 100644
index cab69d7da07..00000000000
--- a/src/vms-pp.trans
+++ /dev/null
@@ -1,10 +0,0 @@
1! translations for extra long variable names
2!234567890123456789012345678901 1234567890123456789012345678901
3Vminibuffer_local_completion_map Vminibuf_local_completion_map
4Vminibuffer_local_must_match_map Vminibuf_local_must_match
5Finsert_abbrev_table_description Finsert_abbrev_table_descrip
6Sinsert_abbrev_table_description Sinsert_abbrev_table_descrip
7internal_with_output_to_temp_buffer internal_with_out_to_temp_buf
8Vminibuffer_completion_predicate Vminibuf_completion_predicate
9Qminibuffer_completion_predicate Qminibuf_completion_predicate
10
diff --git a/src/vms-pwd.h b/src/vms-pwd.h
deleted file mode 100644
index d07fb1dcf59..00000000000
--- a/src/vms-pwd.h
+++ /dev/null
@@ -1,35 +0,0 @@
1/* GNU Emacs password definition file.
2 Copyright (C) 1986 Free Software Foundation.
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 2, 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, Inc., 59 Temple Place - Suite 330,
19Boston, MA 02111-1307, USA. */
20
21#ifdef VMS
22/* On VMS, we read the UAF file and emulate some of the necessary
23 fields for Emacs. */
24#include "uaf.h"
25
26struct passwd {
27 char pw_name[UAF$S_USERNAME+1];
28 char pw_passwd[UAF$S_PWD];
29 short pw_uid;
30 short pw_gid;
31 char pw_gecos[UAF$S_OWNER+1];
32 char pw_dir[UAF$S_DEFDEV+UAF$S_DEFDIR+1];
33 char pw_shell[UAF$S_DEFCLI+1];
34};
35#endif /* VMS */
diff --git a/src/vmsdir.h b/src/vmsdir.h
deleted file mode 100644
index 4b4f6e08068..00000000000
--- a/src/vmsdir.h
+++ /dev/null
@@ -1,98 +0,0 @@
1/* GNU Emacs VMS directory definition file.
2 Copyright (C) 1986 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 2, 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, Inc., 59 Temple Place - Suite 330,
19Boston, MA 02111-1307, USA. */
20
21/*
22 * Files-11 Ver. 2 directory structure (VMS V4.x - long names)
23 */
24#ifndef DIR$K_LENGTH
25
26#define DIR$C_FID 0
27#define DIR$C_LINKNAME 1
28#define DIR$K_LENGTH 6
29#define DIR$C_LENGTH 6
30#define DIR$S_DIRDEF 6
31#define DIR$W_SIZE 0
32#define DIR$W_VERLIMIT 2
33#define DIR$B_FLAGS 4
34#define DIR$S_TYPE 3
35#define DIR$V_TYPE 0
36#define DIR$V_NEXTREC 6
37#define DIR$V_PREVREC 7
38#define DIR$B_NAMECOUNT 5
39#define DIR$S_NAME 80
40#define DIR$T_NAME 6
41
42#define DIR$K_VERSION 8
43#define DIR$C_VERSION 8
44#define DIR$S_DIRDEF1 8
45#define DIR$W_VERSION 0
46#define DIR$S_FID 6
47#define DIR$W_FID 2
48#define DIR$W_FID_NUM 2
49#define DIR$W_FID_SEQ 4
50#define DIR$W_FID_RVN 6
51#define DIR$B_FID_RVN 6
52#define DIR$B_FID_NMX 7
53
54#define DIR$S_DIRDEF2 1
55#define DIR$T_LINKNAME 0
56
57typedef struct dir$_name {
58/* short dir$w_size; /* if you read with RMS, it eats this... */
59 short dir$w_verlimit; /* maximum number of versions */
60 union {
61 unsigned char dir_b_flags;
62#define dir$b_flags dir__b_flags.dir_b_flags
63 struct {
64 unsigned char dir_v_type: DIR$S_TYPE;
65#define dir$v_type dir__b_flags.dir___b_flags.dir_v_type
66 unsigned char: 3;
67 unsigned char dir_v_nextrec: 1;
68#define dir$v_nextrec dir__b_flags.dir___b_flags.dir_v_nextrec
69 unsigned char dir_v_prevrec: 1;
70#define dir$v_prevrec dir__b_flags.dir___b_flags.dir_v_prevrec
71 } dir___b_flags;
72 } dir__b_flags;
73 unsigned char dir$b_namecount;
74 char dir$t_name[];
75} dir$_dirdef; /* only the fixed first part */
76
77typedef struct dir$_version {
78 short dir$w_version;
79 short dir$w_fid_num;
80 short dir$w_fid_seq;
81 union {
82 short dir_w_fid_rvn;
83#define dir$w_fid_rvn dir__w_fid_rvn.dir_w_fid_rvn
84 struct {
85 char dir_b_fid_rvn;
86#define dir$b_fid_rvn dir__w_fid_rvn.dir___w_fid_rvn.dir_b_fid_rvn
87 char dir_b_fid_nmx;
88#define dir$b_fid_nmx dir__w_fid_rvn.dir___w_fid_rvn.dir_b_fid_nmx
89 } dir___w_fid_rvn;
90 } dir__w_fid_rvn;
91} dir$_dirdef1; /* one for each version of the file */
92
93typedef
94struct dir$_linkname {
95 char dir$t_linkname[];
96} dir$_dirdef2;
97
98#endif
diff --git a/src/vmsfns.c b/src/vmsfns.c
deleted file mode 100644
index fe79ebee303..00000000000
--- a/src/vmsfns.c
+++ /dev/null
@@ -1,962 +0,0 @@
1/* VMS subprocess and command interface.
2 Copyright (C) 1987, 1988, 1999 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 2, 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, Inc., 59 Temple Place - Suite 330,
19Boston, MA 02111-1307, USA. */
20
21/* Written by Mukesh Prasad. */
22
23/*
24 * INTERFACE PROVIDED BY EMACS FOR VMS SUBPROCESSES:
25 *
26 * Emacs provides the following functions:
27 *
28 * "spawn-subprocess", which takes as arguments:
29 *
30 * (i) an integer to identify the spawned subprocess in future
31 * operations,
32 * (ii) A function to process input from the subprocess, and
33 * (iii) A function to be called upon subprocess termination.
34 *
35 * First argument is required. If second argument is missing or nil,
36 * the default action is to insert all received messages at the current
37 * location in the current buffer. If third argument is missing or nil,
38 * no action is taken upon subprocess termination.
39 * The input-handler is called as
40 * (input-handler num string)
41 * where num is the identifying integer for the subprocess and string
42 * is a string received from the subprocess. exit-handler is called
43 * with the identifying integer as the argument.
44 *
45 * "send-command-to-subprocess" takes two arguments:
46 *
47 * (i) Subprocess identifying integer.
48 * (ii) String to send as a message to the subprocess.
49 *
50 * "stop-subprocess" takes the subprocess identifying integer as
51 * argument.
52 *
53 * Implementation is done by spawning an asynchronous subprocess, and
54 * communicating to it via mailboxes.
55 */
56
57#ifdef VMS
58
59#include <config.h>
60#include <stdio.h>
61#include <ctype.h>
62#undef NULL
63
64#include "lisp.h"
65#include <descrip.h>
66#include <dvidef.h>
67#include <prvdef.h>
68/* #include <clidef.h> */
69#include <iodef.h>
70#include <ssdef.h>
71#include <errno.h>
72
73#ifdef VMS4_4 /* I am being cautious; perhaps this exists in older versions */
74#include <jpidef.h>
75#endif
76
77/* #include <syidef.h> */
78
79#define CLI$M_NOWAIT 1 /* clidef.h is missing from C library */
80#define SYI$_VERSION 4096 /* syidef.h is missing from C library */
81#define JPI$_CLINAME 522 /* JPI$_CLINAME is missing from jpidef.h */
82#define JPI$_MASTER_PID 805 /* JPI$_MASTER_PID missing from jpidef.h */
83#define LIB$_NOSUCHSYM 1409892 /* libclidef.h missing */
84
85#define MSGSIZE 160 /* Maximum size for mailbox operations */
86
87#ifndef PRV$V_ACNT
88
89/* these defines added as hack for VMS 5.1-1. SJones, 8-17-89 */
90/* this is _really_ nasty and needs to be changed ASAP - should see about
91 using the union defined in SYS$LIBRARY:PRVDEF.H under v5 */
92
93#define PRV$V_ACNT 0x09
94#define PRV$V_ALLSPOOL 0x04
95#define PRV$V_ALTPRI 0x0D
96#define PRV$V_BUGCHK 0x17
97#define PRV$V_BYPASS 0x1D
98#define PRV$V_CMEXEC 0x01
99#define PRV$V_CMKRNL 0x00
100#define PRV$V_DETACH 0x05
101#define PRV$V_DIAGNOSE 0x06
102#define PRV$V_DOWNGRADE 0x21
103#define PRV$V_EXQUOTA 0x13
104#define PRV$V_GROUP 0x08
105#define PRV$V_GRPNAM 0x03
106#define PRV$V_GRPPRV 0x22
107#define PRV$V_LOG_IO 0x07
108#define PRV$V_MOUNT 0x11
109#define PRV$V_NETMBX 0x14
110#define PRV$V_NOACNT 0x09
111#define PRV$V_OPER 0x12
112#define PRV$V_PFNMAP 0x1A
113#define PRV$V_PHY_IO 0x16
114#define PRV$V_PRMCEB 0x0A
115#define PRV$V_PRMGBL 0x18
116#define PRV$V_PRMJNL 0x25
117#define PRV$V_PRMMBX 0x0B
118#define PRV$V_PSWAPM 0x0C
119#define PRV$V_READALL 0x23
120#define PRV$V_SECURITY 0x26
121#define PRV$V_SETPRI 0x0D
122#define PRV$V_SETPRV 0x0E
123#define PRV$V_SHARE 0x1F
124#define PRV$V_SHMEM 0x1B
125#define PRV$V_SYSGBL 0x19
126#define PRV$V_SYSLCK 0x1E
127#define PRV$V_SYSNAM 0x02
128#define PRV$V_SYSPRV 0x1C
129#define PRV$V_TMPJNL 0x24
130#define PRV$V_TMPMBX 0x0F
131#define PRV$V_UPGRADE 0x20
132#define PRV$V_VOLPRO 0x15
133#define PRV$V_WORLD 0x10
134#endif
135
136/* IO status block for mailbox operations. */
137struct mbx_iosb
138{
139 short status;
140 short size;
141 int pid;
142};
143
144/* Structure for maintaining linked list of subprocesses. */
145struct process_list
146{
147 int name; /* Numeric identifier for subprocess */
148 int process_id; /* VMS process address */
149 int process_active; /* 1 iff process has not exited yet */
150 int mbx_chan; /* Mailbox channel to write to process */
151 struct mbx_iosb iosb; /* IO status block for write operations */
152 Lisp_Object input_handler; /* Input handler for subprocess */
153 Lisp_Object exit_handler; /* Exit handler for subprocess */
154 struct process_list * next; /* Linked list chain */
155};
156
157/* Structure for privilege list. */
158struct privilege_list
159{
160 char * name;
161 int mask;
162};
163
164/* Structure for finding VMS related information. */
165struct vms_objlist
166{
167 char * name; /* Name of object */
168 Lisp_Object (* objfn)(); /* Function to retrieve VMS object */
169};
170
171static int exit_ast (); /* Called upon subprocess exit */
172static int create_mbx (); /* Creates mailbox */
173static void mbx_msg (); /* Writes null terminated string to mbx */
174static void write_to_mbx (); /* Writes message to string */
175static void start_mbx_input (); /* Queues I/O request to mailbox */
176
177static int input_mbx_chan = 0; /* Channel to read subprocess input on */
178static char input_mbx_name[20];
179 /* Storage for mailbox device name */
180static struct dsc$descriptor_s input_mbx_dsc;
181 /* Descriptor for mailbox device name */
182static struct process_list * process_list = 0;
183 /* Linked list of subprocesses */
184static char mbx_buffer[MSGSIZE];
185 /* Buffer to read from subprocesses */
186static struct mbx_iosb input_iosb;
187 /* IO status block for mailbox reads */
188
189int have_process_input, /* Non-zero iff subprocess input pending */
190 process_exited; /* Non-zero iff suprocess exit pending */
191
192/* List of privilege names and mask offsets */
193static struct privilege_list priv_list[] = {
194
195 { "ACNT", PRV$V_ACNT },
196 { "ALLSPOOL", PRV$V_ALLSPOOL },
197 { "ALTPRI", PRV$V_ALTPRI },
198 { "BUGCHK", PRV$V_BUGCHK },
199 { "BYPASS", PRV$V_BYPASS },
200 { "CMEXEC", PRV$V_CMEXEC },
201 { "CMKRNL", PRV$V_CMKRNL },
202 { "DETACH", PRV$V_DETACH },
203 { "DIAGNOSE", PRV$V_DIAGNOSE },
204 { "DOWNGRADE", PRV$V_DOWNGRADE }, /* Isn't VMS as low as you can go? */
205 { "EXQUOTA", PRV$V_EXQUOTA },
206 { "GRPPRV", PRV$V_GRPPRV },
207 { "GROUP", PRV$V_GROUP },
208 { "GRPNAM", PRV$V_GRPNAM },
209 { "LOG_IO", PRV$V_LOG_IO },
210 { "MOUNT", PRV$V_MOUNT },
211 { "NETMBX", PRV$V_NETMBX },
212 { "NOACNT", PRV$V_NOACNT },
213 { "OPER", PRV$V_OPER },
214 { "PFNMAP", PRV$V_PFNMAP },
215 { "PHY_IO", PRV$V_PHY_IO },
216 { "PRMCEB", PRV$V_PRMCEB },
217 { "PRMGBL", PRV$V_PRMGBL },
218 { "PRMJNL", PRV$V_PRMJNL },
219 { "PRMMBX", PRV$V_PRMMBX },
220 { "PSWAPM", PRV$V_PSWAPM },
221 { "READALL", PRV$V_READALL },
222 { "SECURITY", PRV$V_SECURITY },
223 { "SETPRI", PRV$V_SETPRI },
224 { "SETPRV", PRV$V_SETPRV },
225 { "SHARE", PRV$V_SHARE },
226 { "SHMEM", PRV$V_SHMEM },
227 { "SYSGBL", PRV$V_SYSGBL },
228 { "SYSLCK", PRV$V_SYSLCK },
229 { "SYSNAM", PRV$V_SYSNAM },
230 { "SYSPRV", PRV$V_SYSPRV },
231 { "TMPJNL", PRV$V_TMPJNL },
232 { "TMPMBX", PRV$V_TMPMBX },
233 { "UPGRADE", PRV$V_UPGRADE },
234 { "VOLPRO", PRV$V_VOLPRO },
235 { "WORLD", PRV$V_WORLD },
236
237 };
238
239static Lisp_Object
240 vms_account(), vms_cliname(), vms_owner(), vms_grp(), vms_image(),
241 vms_parent(), vms_pid(), vms_prcnam(), vms_terminal(), vms_uic_int(),
242 vms_uic_str(), vms_username(), vms_version_fn(), vms_trnlog(),
243 vms_symbol(), vms_proclist();
244
245/* Table of arguments to Fvms_object, and the handlers that get the data. */
246
247static struct vms_objlist vms_object [] = {
248 { "ACCOUNT", vms_account }, /* Returns account name as a string */
249 { "CLINAME", vms_cliname }, /* Returns CLI name (string) */
250 { "OWNER", vms_owner }, /* Returns owner process's PID (int) */
251 { "GRP", vms_grp }, /* Returns group number of UIC (int) */
252 { "IMAGE", vms_image }, /* Returns executing image (string) */
253 { "PARENT", vms_parent }, /* Returns parent proc's PID (int) */
254 { "PID", vms_pid }, /* Returns process's PID (int) */
255 { "PRCNAM", vms_prcnam }, /* Returns process's name (string) */
256 { "TERMINAL", vms_terminal }, /* Returns terminal name (string) */
257 { "UIC", vms_uic_int }, /* Returns UIC as integer */
258 { "UICGRP", vms_uic_str }, /* Returns UIC as string */
259 { "USERNAME", vms_username }, /* Returns username (string) */
260 { "VERSION", vms_version_fn },/* Returns VMS version (string) */
261 { "LOGICAL", vms_trnlog }, /* Translates VMS logical name */
262 { "DCL-SYMBOL", vms_symbol }, /* Translates DCL symbol */
263 { "PROCLIST", vms_proclist }, /* Returns list of all PIDs on system */
264 };
265
266Lisp_Object Qdefault_subproc_input_handler;
267
268extern int process_ef; /* Event flag for subprocess operations */
269
270DEFUN ("default-subprocess-input-handler",
271 Fdefault_subproc_input_handler, Sdefault_subproc_input_handler,
272 2, 2, 0,
273 "Default input handler for input from spawned subprocesses.")
274 (name, input)
275 Lisp_Object name, input;
276{
277 /* Just insert in current buffer */
278 insert1 (input);
279 insert ("\n", 1);
280}
281
282DEFUN ("spawn-subprocess", Fspawn_subprocess, Sspawn_subprocess, 1, 3, 0,
283 "Spawn an asynchronous VMS suprocess for command processing.")
284 (name, input_handler, exit_handler)
285 Lisp_Object name, input_handler, exit_handler;
286{
287 int status;
288 char output_mbx_name[20];
289 struct dsc$descriptor_s output_mbx_dsc;
290 struct process_list *ptr, *p, *prev;
291
292 CHECK_NUMBER (name, 0);
293 if (! input_mbx_chan)
294 {
295 if (! create_mbx (&input_mbx_dsc, input_mbx_name, &input_mbx_chan, 1))
296 return Qnil;
297 start_mbx_input ();
298 }
299 ptr = 0;
300 prev = 0;
301 while (ptr)
302 {
303 struct process_list *next = ptr->next;
304 if (ptr->name == XFASTINT (name))
305 {
306 if (ptr->process_active)
307 return Qt;
308
309 /* Delete this process and run its exit handler. */
310 if (prev)
311 prev->next = next;
312 else
313 process_list = next;
314 if (! NILP (ptr->exit_handler))
315 Feval (Fcons (ptr->exit_handler, Fcons (make_number (ptr->name),
316 Qnil)));
317 sys$dassgn (ptr->mbx_chan);
318 break;
319 }
320 else
321 prev = ptr;
322 ptr = next;
323 }
324 if (! ptr)
325 ptr = xmalloc (sizeof (struct process_list));
326 if (! create_mbx (&output_mbx_dsc, output_mbx_name, &ptr->mbx_chan, 2))
327 {
328 free (ptr);
329 return Qnil;
330 }
331 if (NILP (input_handler))
332 input_handler = Qdefault_subproc_input_handler;
333 ptr->input_handler = input_handler;
334 ptr->exit_handler = exit_handler;
335 message ("Creating subprocess...");
336 status = lib$spawn (0, &output_mbx_dsc, &input_mbx_dsc, &CLI$M_NOWAIT, 0,
337 &ptr->process_id, 0, 0, exit_ast, &ptr->process_active);
338 if (! (status & 1))
339 {
340 sys$dassgn (ptr->mbx_chan);
341 free (ptr);
342 error ("Unable to spawn subprocess");
343 return Qnil;
344 }
345 ptr->name = XFASTINT (name);
346 ptr->next = process_list;
347 ptr->process_active = 1;
348 process_list = ptr;
349 message ("Creating subprocess...done");
350 return Qt;
351}
352
353static void
354mbx_msg (ptr, msg)
355 struct process_list *ptr;
356 char *msg;
357{
358 write_to_mbx (ptr, msg, strlen (msg));
359}
360
361DEFUN ("send-command-to-subprocess",
362 Fsend_command_to_subprocess, Ssend_command_to_subprocess, 2, 2,
363 "sSend command to subprocess: \nsSend subprocess %s command: ",
364 "Send to VMS subprocess named NAME the string COMMAND.")
365 (name, command)
366 Lisp_Object name, command;
367{
368 struct process_list * ptr;
369
370 CHECK_NUMBER (name, 0);
371 CHECK_STRING (command, 1);
372 for (ptr = process_list; ptr; ptr = ptr->next)
373 if (XFASTINT (name) == ptr->name)
374 {
375 write_to_mbx (ptr, XSTRING (command)->data,
376 XSTRING (command)->size);
377 return Qt;
378 }
379 return Qnil;
380}
381
382DEFUN ("stop-subprocess", Fstop_subprocess, Sstop_subprocess, 1, 1,
383 "sStop subprocess: ", "Stop VMS subprocess named NAME.")
384 (name)
385 Lisp_Object name;
386{
387 struct process_list * ptr;
388
389 CHECK_NUMBER (name, 0);
390 for (ptr = process_list; ptr; ptr = ptr->next)
391 if (XFASTINT (name) == ptr->name)
392 {
393 ptr->exit_handler = Qnil;
394 if (sys$delprc (&ptr->process_id, 0) & 1)
395 ptr->process_active = 0;
396 return Qt;
397 }
398 return Qnil;
399}
400
401static int
402exit_ast (active)
403 int * active;
404{
405 process_exited = 1;
406 *active = 0;
407 sys$setef (process_ef);
408}
409
410/* Process to handle input on the input mailbox.
411 * Searches through the list of processes until the matching PID is found,
412 * then calls its input handler.
413 */
414
415process_command_input ()
416{
417 struct process_list * ptr;
418 char * msg;
419 int msglen;
420 Lisp_Object expr;
421
422 msg = mbx_buffer;
423 msglen = input_iosb.size;
424 /* Hack around VMS oddity of sending extraneous CR/LF characters for
425 * some of the commands (but not most).
426 */
427 if (msglen > 0 && *msg == '\r')
428 {
429 msg++;
430 msglen--;
431 }
432 if (msglen > 0 && msg[msglen - 1] == '\n')
433 msglen--;
434 if (msglen > 0 && msg[msglen - 1] == '\r')
435 msglen--;
436 /* Search for the subprocess in the linked list.
437 */
438 expr = Qnil;
439 for (ptr = process_list; ptr; ptr = ptr->next)
440 if (ptr->process_id == input_iosb.pid)
441 {
442 expr = Fcons (ptr->input_handler,
443 Fcons (make_number (ptr->name),
444 Fcons (make_string (msg, msglen),
445 Qnil)));
446 break;
447 }
448 have_process_input = 0;
449 start_mbx_input ();
450 clear_waiting_for_input (); /* Otherwise Ctl-g will cause crash. JCB */
451 if (! NILP (expr))
452 Feval (expr);
453}
454
455/* Searches process list for any processes which have exited. Calls their
456 * exit handlers and removes them from the process list.
457 */
458
459process_exit ()
460{
461 struct process_list * ptr, * prev, * next;
462
463 process_exited = 0;
464 prev = 0;
465 ptr = process_list;
466 while (ptr)
467 {
468 next = ptr->next;
469 if (! ptr->process_active)
470 {
471 if (prev)
472 prev->next = next;
473 else
474 process_list = next;
475 if (! NILP (ptr->exit_handler))
476 Feval (Fcons (ptr->exit_handler, Fcons (make_number (ptr->name),
477 Qnil)));
478 sys$dassgn (ptr->mbx_chan);
479 free (ptr);
480 }
481 else
482 prev = ptr;
483 ptr = next;
484 }
485}
486
487/* Called at emacs exit.
488 */
489
490kill_vms_processes ()
491{
492 struct process_list * ptr;
493
494 for (ptr = process_list; ptr; ptr = ptr->next)
495 if (ptr->process_active)
496 {
497 sys$dassgn (ptr->mbx_chan);
498 sys$delprc (&ptr->process_id, 0);
499 }
500 sys$dassgn (input_mbx_chan);
501 process_list = 0;
502 input_mbx_chan = 0;
503}
504
505/* Creates a temporary mailbox and retrieves its device name in 'buf'.
506 * Makes the descriptor pointed to by 'dsc' refer to this device.
507 * 'buffer_factor' is used to allow sending messages asynchronously
508 * till some point.
509 */
510
511static int
512create_mbx (dsc, buf, chan, buffer_factor)
513 struct dsc$descriptor_s *dsc;
514 char *buf;
515 int *chan;
516 int buffer_factor;
517{
518 int strval[2];
519 int status;
520
521 status = sys$crembx (0, chan, MSGSIZE, MSGSIZE * buffer_factor, 0, 0, 0);
522 if (! (status & 1))
523 {
524 message ("Unable to create mailbox. Need TMPMBX privilege.");
525 return 0;
526 }
527 strval[0] = 16;
528 strval[1] = buf;
529 status = lib$getdvi (&DVI$_DEVNAM, chan, 0, 0, strval,
530 &dsc->dsc$w_length);
531 if (! (status & 1))
532 return 0;
533 dsc->dsc$b_dtype = DSC$K_DTYPE_T;
534 dsc->dsc$b_class = DSC$K_CLASS_S;
535 dsc->dsc$a_pointer = buf;
536 return 1;
537} /* create_mbx */
538
539/* AST routine to be called upon receiving mailbox input.
540 * Sets flag telling keyboard routines that input is available.
541 */
542
543static int
544mbx_input_ast ()
545{
546 have_process_input = 1;
547}
548
549/* Issue a QIO request on the input mailbox.
550 */
551static void
552start_mbx_input ()
553{
554 sys$qio (process_ef, input_mbx_chan, IO$_READVBLK, &input_iosb,
555 mbx_input_ast, 0, mbx_buffer, sizeof (mbx_buffer),
556 0, 0, 0, 0);
557}
558
559/* Send a message to the subprocess input mailbox, without blocking if
560 * possible.
561 */
562static void
563write_to_mbx (ptr, buf, len)
564 struct process_list *ptr;
565 char *buf;
566 int len;
567{
568 sys$qiow (0, ptr->mbx_chan, IO$_WRITEVBLK | IO$M_NOW, &ptr->iosb,
569 0, 0, buf, len, 0, 0, 0, 0);
570}
571
572DEFUN ("setprv", Fsetprv, Ssetprv, 1, 3, 0,
573 "Set or reset a VMS privilege. First arg is privilege name.\n\
574Second arg is t or nil, indicating whether the privilege is to be\n\
575set or reset. Default is nil. Returns t if success, nil if not.\n\
576If third arg is non-nil, does not change privilege, but returns t\n\
577or nil depending upon whether the privilege is already enabled.")
578 (priv, value, getprv)
579 Lisp_Object priv, value, getprv;
580{
581 int prvmask[2], prvlen, newmask[2];
582 char * prvname;
583 int found, i;
584 struct privilege_list * ptr;
585
586 CHECK_STRING (priv, 0);
587 priv = Fupcase (priv);
588 prvname = XSTRING (priv)->data;
589 prvlen = XSTRING (priv)->size;
590 found = 0;
591 prvmask[0] = 0;
592 prvmask[1] = 0;
593 for (i = 0; i < sizeof (priv_list) / sizeof (priv_list[0]); i++)
594 {
595 ptr = &priv_list[i];
596 if (prvlen == strlen (ptr->name) &&
597 bcmp (prvname, ptr->name, prvlen) == 0)
598 {
599 if (ptr->mask >= 32)
600 prvmask[1] = 1 << (ptr->mask % 32);
601 else
602 prvmask[0] = 1 << ptr->mask;
603 found = 1;
604 break;
605 }
606 }
607 if (! found)
608 error ("Unknown privilege name %s", XSTRING (priv)->data);
609 if (NILP (getprv))
610 {
611 if (sys$setprv (NILP (value) ? 0 : 1, prvmask, 0, 0) == SS$_NORMAL)
612 return Qt;
613 return Qnil;
614 }
615 /* Get old priv value */
616 if (sys$setprv (0, 0, 0, newmask) != SS$_NORMAL)
617 return Qnil;
618 if ((newmask[0] & prvmask[0])
619 || (newmask[1] & prvmask[1]))
620 return Qt;
621 return Qnil;
622}
623
624/* Retrieves VMS system information. */
625
626#ifdef VMS4_4 /* I don't know whether these functions work in old versions */
627
628DEFUN ("vms-system-info", Fvms_system_info, Svms_system_info, 1, 3, 0,
629 "Retrieve VMS process and system information.\n\
630The first argument (a string) specifies the type of information desired.\n\
631The other arguments depend on the type you select.\n\
632For information about a process, the second argument is a process ID\n\
633or a process name, with the current process as a default.\n\
634These are the possibilities for the first arg (upper or lower case ok):\n\
635 account Returns account name\n\
636 cliname Returns CLI name\n\
637 owner Returns owner process's PID\n\
638 grp Returns group number\n\
639 parent Returns parent process's PID\n\
640 pid Returns process's PID\n\
641 prcnam Returns process's name\n\
642 terminal Returns terminal name\n\
643 uic Returns UIC number\n\
644 uicgrp Returns formatted [UIC,GRP]\n\
645 username Returns username\n\
646 version Returns VMS version\n\
647 logical Translates VMS logical name (second argument)\n\
648 dcl-symbol Translates DCL symbol (second argument)\n\
649 proclist Returns list of all PIDs on system (needs WORLD privilege)." )
650 (type, arg1, arg2)
651 Lisp_Object type, arg1, arg2;
652{
653 int i, typelen;
654 char * typename;
655 struct vms_objlist * ptr;
656
657 CHECK_STRING (type, 0);
658 type = Fupcase (type);
659 typename = XSTRING (type)->data;
660 typelen = XSTRING (type)->size;
661 for (i = 0; i < sizeof (vms_object) / sizeof (vms_object[0]); i++)
662 {
663 ptr = &vms_object[i];
664 if (typelen == strlen (ptr->name)
665 && bcmp (typename, ptr->name, typelen) == 0)
666 return (* ptr->objfn)(arg1, arg2);
667 }
668 error ("Unknown object type %s", typename);
669}
670
671/* Given a reference to a VMS process, returns its process id. */
672
673static int
674translate_id (pid, owner)
675 Lisp_Object pid;
676 int owner; /* if pid is null/0, return owner. If this
677 * flag is 0, return self. */
678{
679 int status, code, id, i, numeric, size;
680 char * p;
681 int prcnam[2];
682
683 if (NILP (pid)
684 || STRINGP (pid) && XSTRING (pid)->size == 0
685 || INTEGERP (pid) && XFASTINT (pid) == 0)
686 {
687 code = owner ? JPI$_OWNER : JPI$_PID;
688 status = lib$getjpi (&code, 0, 0, &id);
689 if (! (status & 1))
690 error ("Cannot find %s: %s",
691 owner ? "owner process" : "process id",
692 vmserrstr (status));
693 return (id);
694 }
695 if (INTEGERP (pid))
696 return (XFASTINT (pid));
697 CHECK_STRING (pid, 0);
698 pid = Fupcase (pid);
699 size = XSTRING (pid)->size;
700 p = XSTRING (pid)->data;
701 numeric = 1;
702 id = 0;
703 for (i = 0; i < size; i++, p++)
704 if (isxdigit (*p))
705 {
706 id *= 16;
707 if (*p >= '0' && *p <= '9')
708 id += *p - '0';
709 else
710 id += *p - 'A' + 10;
711 }
712 else
713 {
714 numeric = 0;
715 break;
716 }
717 if (numeric)
718 return (id);
719 prcnam[0] = XSTRING (pid)->size;
720 prcnam[1] = XSTRING (pid)->data;
721 status = lib$getjpi (&JPI$_PID, 0, prcnam, &id);
722 if (! (status & 1))
723 error ("Cannot find process id: %s",
724 vmserrstr (status));
725 return (id);
726} /* translate_id */
727
728/* VMS object retrieval functions. */
729
730static Lisp_Object
731getjpi (jpicode, arg, numeric)
732 int jpicode; /* Type of GETJPI information */
733 Lisp_Object arg;
734 int numeric; /* 1 if numeric value expected */
735{
736 int id, status, numval;
737 char str[128];
738 int strdsc[2] = { sizeof (str), str };
739 short strlen;
740
741 id = translate_id (arg, 0);
742 status = lib$getjpi (&jpicode, &id, 0, &numval, strdsc, &strlen);
743 if (! (status & 1))
744 error ("Unable to retrieve information: %s",
745 vmserrstr (status));
746 if (numeric)
747 return (make_number (numval));
748 return (make_string (str, strlen));
749}
750
751static Lisp_Object
752vms_account (arg1, arg2)
753 Lisp_Object arg1, arg2;
754{
755 return getjpi (JPI$_ACCOUNT, arg1, 0);
756}
757
758static Lisp_Object
759vms_cliname (arg1, arg2)
760 Lisp_Object arg1, arg2;
761{
762 return getjpi (JPI$_CLINAME, arg1, 0);
763}
764
765static Lisp_Object
766vms_grp (arg1, arg2)
767 Lisp_Object arg1, arg2;
768{
769 return getjpi (JPI$_GRP, arg1, 1);
770}
771
772static Lisp_Object
773vms_image (arg1, arg2)
774 Lisp_Object arg1, arg2;
775{
776 return getjpi (JPI$_IMAGNAME, arg1, 0);
777}
778
779static Lisp_Object
780vms_owner (arg1, arg2)
781 Lisp_Object arg1, arg2;
782{
783 return getjpi (JPI$_OWNER, arg1, 1);
784}
785
786static Lisp_Object
787vms_parent (arg1, arg2)
788 Lisp_Object arg1, arg2;
789{
790 return getjpi (JPI$_MASTER_PID, arg1, 1);
791}
792
793static Lisp_Object
794vms_pid (arg1, arg2)
795 Lisp_Object arg1, arg2;
796{
797 return getjpi (JPI$_PID, arg1, 1);
798}
799
800static Lisp_Object
801vms_prcnam (arg1, arg2)
802 Lisp_Object arg1, arg2;
803{
804 return getjpi (JPI$_PRCNAM, arg1, 0);
805}
806
807static Lisp_Object
808vms_terminal (arg1, arg2)
809 Lisp_Object arg1, arg2;
810{
811 return getjpi (JPI$_TERMINAL, arg1, 0);
812}
813
814static Lisp_Object
815vms_uic_int (arg1, arg2)
816 Lisp_Object arg1, arg2;
817{
818 return getjpi (JPI$_UIC, arg1, 1);
819}
820
821static Lisp_Object
822vms_uic_str (arg1, arg2)
823 Lisp_Object arg1, arg2;
824{
825 return getjpi (JPI$_UIC, arg1, 0);
826}
827
828static Lisp_Object
829vms_username (arg1, arg2)
830 Lisp_Object arg1, arg2;
831{
832 return getjpi (JPI$_USERNAME, arg1, 0);
833}
834
835static Lisp_Object
836vms_version_fn (arg1, arg2)
837 Lisp_Object arg1, arg2;
838{
839 char str[40];
840 int status;
841 int strdsc[2] = { sizeof (str), str };
842 short strlen;
843
844 status = lib$getsyi (&SYI$_VERSION, 0, strdsc, &strlen, 0, 0);
845 if (! (status & 1))
846 error ("Unable to obtain version: %s", vmserrstr (status));
847 return (make_string (str, strlen));
848}
849
850static Lisp_Object
851vms_trnlog (arg1, arg2)
852 Lisp_Object arg1, arg2;
853{
854 char str[256]; /* Max logical translation is 255 bytes. */
855 int status, symdsc[2];
856 int strdsc[2] = { sizeof (str), str };
857 short length, level;
858
859 CHECK_STRING (arg1, 0);
860 symdsc[0] = XSTRING (arg1)->size;
861 symdsc[1] = XSTRING (arg1)->data;
862 status = lib$sys_trnlog (symdsc, &length, strdsc);
863 if (! (status & 1))
864 error ("Unable to translate logical name: %s", vmserrstr (status));
865 if (status == SS$_NOTRAN)
866 return (Qnil);
867 return (make_string (str, length));
868}
869
870static Lisp_Object
871vms_symbol (arg1, arg2)
872 Lisp_Object arg1, arg2;
873{
874 char str[1025]; /* Max symbol translation is 1024 bytes. */
875 int status, symdsc[2];
876 int strdsc[2] = { sizeof (str), str };
877 short length, level;
878
879 CHECK_STRING (arg1, 0);
880 symdsc[0] = XSTRING (arg1)->size;
881 symdsc[1] = XSTRING (arg1)->data;
882 status = lib$get_symbol (symdsc, strdsc, &length, &level);
883 if (! (status & 1)) {
884 if (status == LIB$_NOSUCHSYM)
885 return (Qnil);
886 else
887 error ("Unable to translate symbol: %s", vmserrstr (status));
888 }
889 return (make_string (str, length));
890}
891
892static Lisp_Object
893vms_proclist (arg1, arg2)
894 Lisp_Object arg1, arg2;
895{
896 Lisp_Object retval;
897 int id, status, pid;
898
899 retval = Qnil;
900 pid = -1;
901 for (;;)
902 {
903 status = lib$getjpi (&JPI$_PID, &pid, 0, &id);
904 if (status == SS$_NOMOREPROC)
905 break;
906 if (! (status & 1))
907 error ("Unable to get process ID: %s", vmserrstr (status));
908 retval = Fcons (make_number (id), retval);
909 }
910 return (Fsort (retval, intern ("<")));
911}
912
913DEFUN ("shrink-to-icon", Fshrink_to_icon, Sshrink_to_icon, 0, 0, 0,
914 "If emacs is running in a workstation window, shrink to an icon.")
915 ()
916{
917 static char result[128];
918 static $DESCRIPTOR (result_descriptor, result);
919 static $DESCRIPTOR (tt_name, "TT:");
920 static int chan = 0;
921 static int buf = 0x9d + ('2'<<8) + ('2'<<16) + (0x9c<<24);
922 int status;
923 static int temp = JPI$_TERMINAL;
924
925 status = lib$getjpi (&temp, 0, 0, 0, &result_descriptor, 0);
926 if (status != SS$_NORMAL)
927 error ("Unable to determine terminal type.");
928 if (result[0] != 'W' || result[1] != 'T') /* see if workstation */
929 error ("Can't shrink-to-icon on a non workstation terminal");
930 if (!chan) /* assign channel if not assigned */
931 if ((status = sys$assign (&tt_name, &chan, 0, 0)) != SS$_NORMAL)
932 error ("Can't assign terminal, %d", status);
933 status = sys$qiow (0, chan, IO$_WRITEVBLK+IO$M_BREAKTHRU, 0, 0, 0,
934 &buf, 4, 0, 0, 0, 0);
935 if (status != SS$_NORMAL)
936 error ("Can't shrink-to-icon, %d", status);
937}
938
939#endif /* VMS4_4 */
940
941init_vmsfns ()
942{
943 process_list = 0;
944 input_mbx_chan = 0;
945}
946
947syms_of_vmsfns ()
948{
949 defsubr (&Sdefault_subproc_input_handler);
950 defsubr (&Sspawn_subprocess);
951 defsubr (&Ssend_command_to_subprocess);
952 defsubr (&Sstop_subprocess);
953 defsubr (&Ssetprv);
954#ifdef VMS4_4
955 defsubr (&Svms_system_info);
956 defsubr (&Sshrink_to_icon);
957#endif /* VMS4_4 */
958 Qdefault_subproc_input_handler = intern ("default-subprocess-input-handler");
959 staticpro (&Qdefault_subproc_input_handler);
960}
961#endif /* VMS */
962
diff --git a/src/vmsgmalloc.c b/src/vmsgmalloc.c
deleted file mode 100644
index 93a3fd7f8bd..00000000000
--- a/src/vmsgmalloc.c
+++ /dev/null
@@ -1,2012 +0,0 @@
1/* DO NOT EDIT THIS FILE -- it is automagically generated. -*- C -*- */
2
3#define _MALLOC_INTERNAL
4
5/* The malloc headers and source files from the C library follow here. */
6
7/* Declarations for `malloc' and friends.
8 Copyright 1990, 1991, 1992, 1993, 1999 Free Software Foundation, Inc.
9 Written May 1989 by Mike Haertel.
10
11This file is part of GNU Emacs.
12
13GNU Emacs is free software; you can redistribute it and/or modify
14it under the terms of the GNU General Public License as published by
15the Free Software Foundation; either version 2, or (at your option)
16any later version.
17
18GNU Emacs is distributed in the hope that it will be useful,
19but WITHOUT ANY WARRANTY; without even the implied warranty of
20MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21GNU General Public License for more details.
22
23You should have received a copy of the GNU General Public License
24along with GNU Emacs; see the file COPYING. If not, write to
25the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26Boston, MA 02111-1307, USA.
27
28 The author may be reached (Email) at the address mike@ai.mit.edu,
29 or (US mail) as Mike Haertel c/o Free Software Foundation. */
30
31#ifndef _MALLOC_H
32
33#define _MALLOC_H 1
34
35#ifdef __cplusplus
36extern "C"
37{
38#endif
39
40#if defined (__cplusplus) || (defined (__STDC__) && __STDC__)
41#undef __P
42#define __P(args) args
43#undef __const
44#define __const const
45#undef __ptr_t
46#define __ptr_t void *
47#else /* Not C++ or ANSI C. */
48#undef __P
49#define __P(args) ()
50#undef __const
51#define __const
52#undef __ptr_t
53#define __ptr_t char *
54#endif /* C++ or ANSI C. */
55
56#ifndef NULL
57#define NULL 0
58#endif
59
60#if defined (HAVE_CONFIG_H) || defined (emacs)
61#include <config.h>
62#endif
63
64#ifdef __STDC__
65#include <stddef.h>
66#else
67#ifdef VMS /* The following are defined in stdio.h, but we need it NOW!
68 But do NOT do it with defines here, for then, VAX C is going
69 to barf when it gets to stdio.h and the typedefs in there! */
70typedef unsigned int size_t;
71typedef int ptrdiff_t;
72#else /* not VMS */
73#undef size_t
74#define size_t unsigned int
75#undef ptrdiff_t
76#define ptrdiff_t int
77#endif /* VMS */
78#endif
79
80
81/* Allocate SIZE bytes of memory. */
82extern __ptr_t malloc __P ((size_t __size));
83/* Re-allocate the previously allocated block
84 in __ptr_t, making the new block SIZE bytes long. */
85extern __ptr_t realloc __P ((__ptr_t __ptr, size_t __size));
86/* Allocate NMEMB elements of SIZE bytes each, all initialized to 0. */
87extern __ptr_t calloc __P ((size_t __nmemb, size_t __size));
88/* Free a block allocated by `malloc', `realloc' or `calloc'. */
89extern void free __P ((__ptr_t __ptr));
90
91/* Allocate SIZE bytes allocated to ALIGNMENT bytes. */
92extern __ptr_t memalign __P ((size_t __alignment, size_t __size));
93
94/* Allocate SIZE bytes on a page boundary. */
95extern __ptr_t valloc __P ((size_t __size));
96
97#ifdef VMS
98/* VMS hooks to deal with two heaps */
99/* Allocate SIZE bytes of memory. */
100extern __ptr_t __vms_malloc __P ((size_t __size));
101/* Re-allocate the previously allocated block
102 in __ptr_t, making the new block SIZE bytes long. */
103extern __ptr_t __vms_realloc __P ((__ptr_t __ptr, size_t __size));
104/* Free a block allocated by `malloc', `realloc' or `calloc'. */
105extern void __vms_free __P ((__ptr_t __ptr));
106#endif
107
108#ifdef _MALLOC_INTERNAL
109
110#include <stdio.h> /* Harmless, gets __GNU_LIBRARY__ defined. */
111
112#if defined(__GNU_LIBRARY__) || defined(STDC_HEADERS) || defined(USG)
113#include <string.h>
114#else
115#ifndef memset
116#define memset(s, zero, n) bzero ((s), (n))
117#endif
118#ifndef memcpy
119#define memcpy(d, s, n) bcopy ((s), (d), (n))
120#endif
121#ifndef memmove
122#define memmove(d, s, n) bcopy ((s), (d), (n))
123#endif
124#endif
125
126
127#if defined(__GNU_LIBRARY__) || defined(__STDC__)
128#include <limits.h>
129#else
130#define CHAR_BIT 8
131#endif
132
133/* The allocator divides the heap into blocks of fixed size; large
134 requests receive one or more whole blocks, and small requests
135 receive a fragment of a block. Fragment sizes are powers of two,
136 and all fragments of a block are the same size. When all the
137 fragments in a block have been freed, the block itself is freed. */
138#define INT_BIT (CHAR_BIT * sizeof(int))
139#ifdef VMS
140#define BLOCKLOG 9
141#else
142#define BLOCKLOG (INT_BIT > 16 ? 12 : 9)
143#endif
144#define BLOCKSIZE (1 << BLOCKLOG)
145#define BLOCKIFY(SIZE) (((SIZE) + BLOCKSIZE - 1) / BLOCKSIZE)
146
147/* Determine the amount of memory spanned by the initial heap table
148 (not an absolute limit). */
149#define HEAP (INT_BIT > 16 ? 4194304 : 65536)
150
151/* Number of contiguous free blocks allowed to build up at the end of
152 memory before they will be returned to the system. */
153#define FINAL_FREE_BLOCKS 8
154
155/* Data structure giving per-block information. */
156typedef union
157 {
158 /* Heap information for a busy block. */
159 struct
160 {
161 /* Zero for a large block, or positive giving the
162 logarithm to the base two of the fragment size. */
163 int type;
164 union
165 {
166 struct
167 {
168 size_t nfree; /* Free fragments in a fragmented block. */
169 size_t first; /* First free fragment of the block. */
170 } frag;
171 /* Size (in blocks) of a large cluster. */
172 size_t size;
173 } info;
174 } busy;
175 /* Heap information for a free block
176 (that may be the first of a free cluster). */
177 struct
178 {
179 size_t size; /* Size (in blocks) of a free cluster. */
180 size_t next; /* Index of next free cluster. */
181 size_t prev; /* Index of previous free cluster. */
182 } free;
183 } malloc_info;
184
185/* Pointer to first block of the heap. */
186extern char *_heapbase;
187
188/* Table indexed by block number giving per-block information. */
189extern malloc_info *_heapinfo;
190
191/* Address to block number and vice versa. */
192#define BLOCK(A) (((char *) (A) - _heapbase) / BLOCKSIZE + 1)
193#define ADDRESS(B) ((__ptr_t) (((B) - 1) * BLOCKSIZE + _heapbase))
194
195/* Current search index for the heap table. */
196extern size_t _heapindex;
197
198/* Limit of valid info table indices. */
199extern size_t _heaplimit;
200
201/* Doubly linked lists of free fragments. */
202struct list
203 {
204 struct list *next;
205 struct list *prev;
206 };
207
208/* Free list headers for each fragment size. */
209extern struct list _fraghead[];
210
211/* List of blocks allocated with `memalign' (or `valloc'). */
212struct alignlist
213 {
214 struct alignlist *next;
215 __ptr_t aligned; /* The address that memaligned returned. */
216 __ptr_t exact; /* The address that malloc returned. */
217 };
218extern struct alignlist *_aligned_blocks;
219
220/* Instrumentation. */
221extern size_t _chunks_used;
222extern size_t _bytes_used;
223extern size_t _chunks_free;
224extern size_t _bytes_free;
225
226/* Internal version of `free' used in `morecore' (malloc.c). */
227extern void _free_internal __P ((__ptr_t __ptr));
228
229#endif /* _MALLOC_INTERNAL. */
230
231/* Underlying allocation function; successive calls should
232 return contiguous pieces of memory. */
233/* It does NOT always return contiguous pieces of memory on VMS. */
234extern __ptr_t (*__morecore) __P ((ptrdiff_t __size));
235
236/* Underlying deallocation function. It accepts both a pointer and
237 a size to back up. It is implementation dependent what is really
238 used. */
239extern __ptr_t (*__lesscore) __P ((__ptr_t __ptr, ptrdiff_t __size));
240
241/* Default value of `__morecore'. */
242extern __ptr_t __default_morecore __P ((ptrdiff_t __size));
243
244/* Default value of `__lesscore'. */
245extern __ptr_t __default_lesscore __P ((__ptr_t __ptr, ptrdiff_t __size));
246
247#ifdef VMS
248/* Default value of `__morecore'. */
249extern __ptr_t __vms_morecore __P ((ptrdiff_t __size));
250
251/* Default value of `__lesscore'. */
252extern __ptr_t __vms_lesscore __P ((__ptr_t __ptr, ptrdiff_t __size));
253#endif
254
255/* If not NULL, this function is called after each time
256 `__morecore' is called to increase the data size. */
257extern void (*__after_morecore_hook) __P ((void));
258
259/* If not NULL, this function is called after each time
260 `__lesscore' is called to increase the data size. */
261extern void (*__after_lesscore_hook) __P ((void));
262
263/* Nonzero if `malloc' has been called and done its initialization. */
264extern int __malloc_initialized;
265
266/* Hooks for debugging versions. */
267extern void (*__free_hook) __P ((__ptr_t __ptr));
268extern __ptr_t (*__malloc_hook) __P ((size_t __size));
269extern __ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, size_t __size));
270
271/* Activate a standard collection of debugging hooks. */
272extern int mcheck __P ((void (*__func) __P ((void))));
273
274/* Activate a standard collection of tracing hooks. */
275extern void mtrace __P ((void));
276
277/* Statistics available to the user. */
278struct mstats
279 {
280 size_t bytes_total; /* Total size of the heap. */
281 size_t chunks_used; /* Chunks allocated by the user. */
282 size_t bytes_used; /* Byte total of user-allocated chunks. */
283 size_t chunks_free; /* Chunks in the free list. */
284 size_t bytes_free; /* Byte total of chunks in the free list. */
285 };
286
287/* Pick up the current statistics. */
288extern struct mstats mstats __P ((void));
289
290/* Call WARNFUN with a warning message when memory usage is high. */
291extern void memory_warnings __P ((__ptr_t __start,
292 void (*__warnfun) __P ((__const char *))));
293
294
295/* Relocating allocator. */
296
297/* Allocate SIZE bytes, and store the address in *HANDLEPTR. */
298extern __ptr_t r_alloc __P ((__ptr_t *__handleptr, size_t __size));
299
300/* Free the storage allocated in HANDLEPTR. */
301extern void r_alloc_free __P ((__ptr_t *__handleptr));
302
303/* Adjust the block at HANDLEPTR to be SIZE bytes long. */
304extern __ptr_t r_re_alloc __P ((__ptr_t *__handleptr, size_t __size));
305
306
307#ifdef __cplusplus
308}
309#endif
310
311#endif /* malloc.h */
312/* Memory allocator `malloc'.
313 Copyright 1990, 1991, 1992, 1993 Free Software Foundation
314 Written May 1989 by Mike Haertel.
315
316This library is free software; you can redistribute it and/or
317modify it under the terms of the GNU Library General Public License as
318published by the Free Software Foundation; either version 2 of the
319License, or (at your option) any later version.
320
321This library is distributed in the hope that it will be useful,
322but WITHOUT ANY WARRANTY; without even the implied warranty of
323MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
324Library General Public License for more details.
325
326You should have received a copy of the GNU Library General Public
327License along with this library; see the file COPYING.LIB. If
328not, write to the Free Software Foundation, Inc., 675 Mass Ave,
329Cambridge, MA 02139, USA.
330
331 The author may be reached (Email) at the address mike@ai.mit.edu,
332 or (US mail) as Mike Haertel c/o Free Software Foundation. */
333
334#ifndef _MALLOC_INTERNAL
335#define _MALLOC_INTERNAL
336#include <malloc.h>
337#endif
338
339#ifdef VMS
340/* How to really get more memory. */
341__ptr_t (*__morecore) __P ((ptrdiff_t __size)) = __vms_morecore;
342#else
343/* How to really get more memory. */
344__ptr_t (*__morecore) __P ((ptrdiff_t __size)) = __default_morecore;
345#endif
346
347/* Debugging hook for `malloc'. */
348#ifdef VMS
349__ptr_t (*__malloc_hook) __P ((size_t __size)) = __vms_malloc;
350#else
351__ptr_t (*__malloc_hook) __P ((size_t __size));
352#endif
353
354/* Pointer to the base of the first block. */
355char *_heapbase;
356
357/* Block information table. Allocated with align/__free (not malloc/free). */
358malloc_info *_heapinfo;
359
360/* Number of info entries. */
361static size_t heapsize;
362
363/* Search index in the info table. */
364size_t _heapindex;
365
366/* Limit of valid info table indices. */
367size_t _heaplimit;
368
369/* Free lists for each fragment size. */
370struct list _fraghead[BLOCKLOG];
371
372/* Instrumentation. */
373size_t _chunks_used;
374size_t _bytes_used;
375size_t _chunks_free;
376size_t _bytes_free;
377
378/* Are you experienced? */
379int __malloc_initialized;
380
381void (*__after_morecore_hook) __P ((void));
382
383/* Aligned allocation. */
384static __ptr_t align __P ((size_t));
385static __ptr_t
386align (size)
387 size_t size;
388{
389 __ptr_t result;
390 unsigned long int adj;
391
392 result = (*__morecore) (size);
393 adj = (unsigned long int) ((unsigned long int) ((char *) result -
394 (char *) NULL)) % BLOCKSIZE;
395 if (adj != 0)
396 {
397 adj = BLOCKSIZE - adj;
398 (void) (*__morecore) (adj);
399 result = (char *) result + adj;
400 }
401
402 if (__after_morecore_hook)
403 (*__after_morecore_hook) ();
404
405 return result;
406}
407
408/* Set everything up and remember that we have. */
409static int initialize __P ((void));
410static int
411initialize ()
412{
413#ifdef RL_DEBUG
414 extern VMS_present_buffer();
415 printf("__malloc_initialized = %d\n", __malloc_initialized);
416 VMS_present_buffer();
417#endif
418 heapsize = HEAP / BLOCKSIZE;
419 _heapinfo = (malloc_info *) align (heapsize * sizeof (malloc_info));
420 if (_heapinfo == NULL)
421 return 0;
422 memset (_heapinfo, 0, heapsize * sizeof (malloc_info));
423 _heapinfo[0].free.size = 0;
424 _heapinfo[0].free.next = _heapinfo[0].free.prev = 0;
425 _heapindex = 0;
426 _heapbase = (char *) _heapinfo;
427#ifdef RL_DEBUG
428/* debug */
429 printf("_heapbase = 0%o/0x%x/%d\n", _heapbase, _heapbase, _heapbase);
430/* end debug */
431#endif
432 __malloc_initialized = 1;
433 return 1;
434}
435
436/* Get neatly aligned memory, initializing or
437 growing the heap info table as necessary. */
438static __ptr_t morecore __P ((size_t));
439static __ptr_t
440morecore (size)
441 size_t size;
442{
443 __ptr_t result;
444 malloc_info *newinfo, *oldinfo;
445 size_t newsize;
446
447 result = align (size);
448 if (result == NULL)
449 return NULL;
450
451 /* Check if we need to grow the info table. */
452 if ((size_t) BLOCK ((char *) result + size) > heapsize)
453 {
454 newsize = heapsize;
455 while ((size_t) BLOCK ((char *) result + size) > newsize)
456 newsize *= 2;
457 newinfo = (malloc_info *) align (newsize * sizeof (malloc_info));
458 if (newinfo == NULL)
459 {
460 (*__lesscore) (result, size);
461 return NULL;
462 }
463 memset (newinfo, 0, newsize * sizeof (malloc_info));
464 memcpy (newinfo, _heapinfo, heapsize * sizeof (malloc_info));
465 oldinfo = _heapinfo;
466 newinfo[BLOCK (oldinfo)].busy.type = 0;
467 newinfo[BLOCK (oldinfo)].busy.info.size
468 = BLOCKIFY (heapsize * sizeof (malloc_info));
469 _heapinfo = newinfo;
470 _free_internal (oldinfo);
471 heapsize = newsize;
472 }
473
474 _heaplimit = BLOCK ((char *) result + size);
475 return result;
476}
477
478/* Allocate memory from the heap. */
479__ptr_t
480malloc (size)
481 size_t size;
482{
483 __ptr_t result;
484 size_t block, blocks, lastblocks, start;
485 register size_t i;
486 struct list *next;
487
488 if (size == 0)
489 return NULL;
490
491 if (__malloc_hook != NULL)
492 return (*__malloc_hook) (size);
493
494 if (!__malloc_initialized)
495 if (!initialize ())
496 return NULL;
497
498 if (size < sizeof (struct list))
499 size = sizeof (struct list);
500
501 /* Determine the allocation policy based on the request size. */
502 if (size <= BLOCKSIZE / 2)
503 {
504 /* Small allocation to receive a fragment of a block.
505 Determine the logarithm to base two of the fragment size. */
506 register size_t log = 1;
507 --size;
508 while ((size /= 2) != 0)
509 ++log;
510
511 /* Look in the fragment lists for a
512 free fragment of the desired size. */
513 next = _fraghead[log].next;
514 if (next != NULL)
515 {
516 /* There are free fragments of this size.
517 Pop a fragment out of the fragment list and return it.
518 Update the block's nfree and first counters. */
519 result = (__ptr_t) next;
520 next->prev->next = next->next;
521 if (next->next != NULL)
522 next->next->prev = next->prev;
523 block = BLOCK (result);
524 if (--_heapinfo[block].busy.info.frag.nfree != 0)
525 _heapinfo[block].busy.info.frag.first = (unsigned long int)
526 ((unsigned long int) ((char *) next->next - (char *) NULL)
527 % BLOCKSIZE) >> log;
528
529 /* Update the statistics. */
530 ++_chunks_used;
531 _bytes_used += 1 << log;
532 --_chunks_free;
533 _bytes_free -= 1 << log;
534 }
535 else
536 {
537 /* No free fragments of the desired size, so get a new block
538 and break it into fragments, returning the first. */
539 result = malloc (BLOCKSIZE);
540 if (result == NULL)
541 return NULL;
542
543 /* Link all fragments but the first into the free list. */
544 for (i = 1; i < (size_t) (BLOCKSIZE >> log); ++i)
545 {
546 next = (struct list *) ((char *) result + (i << log));
547#ifdef RL_DEBUG
548 printf("DEBUG: malloc (%d): next = %p\n", size, next);
549#endif
550 next->next = _fraghead[log].next;
551 next->prev = &_fraghead[log];
552 next->prev->next = next;
553 if (next->next != NULL)
554 next->next->prev = next;
555 }
556
557 /* Initialize the nfree and first counters for this block. */
558 block = BLOCK (result);
559 _heapinfo[block].busy.type = log;
560 _heapinfo[block].busy.info.frag.nfree = i - 1;
561 _heapinfo[block].busy.info.frag.first = i - 1;
562
563 _chunks_free += (BLOCKSIZE >> log) - 1;
564 _bytes_free += BLOCKSIZE - (1 << log);
565 _bytes_used -= BLOCKSIZE - (1 << log);
566 }
567 }
568 else
569 {
570 /* Large allocation to receive one or more blocks.
571 Search the free list in a circle starting at the last place visited.
572 If we loop completely around without finding a large enough
573 space we will have to get more memory from the system. */
574 blocks = BLOCKIFY (size);
575 start = block = _heapindex;
576 while (_heapinfo[block].free.size < blocks)
577 {
578 block = _heapinfo[block].free.next;
579 if (block == start)
580 {
581 /* Need to get more from the system. Check to see if
582 the new core will be contiguous with the final free
583 block; if so we don't need to get as much. */
584 block = _heapinfo[0].free.prev;
585 lastblocks = _heapinfo[block].free.size;
586 if (_heaplimit != 0 && block + lastblocks == _heaplimit &&
587 (*__morecore) (0) == ADDRESS (block + lastblocks) &&
588 (morecore ((blocks - lastblocks) * BLOCKSIZE)) != NULL)
589 {
590 _heapinfo[block].free.size = blocks;
591 _bytes_free += (blocks - lastblocks) * BLOCKSIZE;
592 continue;
593 }
594 result = morecore (blocks * BLOCKSIZE);
595 if (result == NULL)
596 return NULL;
597 block = BLOCK (result);
598 _heapinfo[block].busy.type = 0;
599 _heapinfo[block].busy.info.size = blocks;
600 ++_chunks_used;
601 _bytes_used += blocks * BLOCKSIZE;
602 return result;
603 }
604 }
605
606 /* At this point we have found a suitable free list entry.
607 Figure out how to remove what we need from the list. */
608 result = ADDRESS (block);
609 if (_heapinfo[block].free.size > blocks)
610 {
611 /* The block we found has a bit left over,
612 so relink the tail end back into the free list. */
613 _heapinfo[block + blocks].free.size
614 = _heapinfo[block].free.size - blocks;
615 _heapinfo[block + blocks].free.next
616 = _heapinfo[block].free.next;
617 _heapinfo[block + blocks].free.prev
618 = _heapinfo[block].free.prev;
619 _heapinfo[_heapinfo[block].free.prev].free.next
620 = _heapinfo[_heapinfo[block].free.next].free.prev
621 = _heapindex = block + blocks;
622 }
623 else
624 {
625 /* The block exactly matches our requirements,
626 so just remove it from the list. */
627 _heapinfo[_heapinfo[block].free.next].free.prev
628 = _heapinfo[block].free.prev;
629 _heapinfo[_heapinfo[block].free.prev].free.next
630 = _heapindex = _heapinfo[block].free.next;
631 --_chunks_free;
632 }
633
634 _heapinfo[block].busy.type = 0;
635 _heapinfo[block].busy.info.size = blocks;
636 ++_chunks_used;
637 _bytes_used += blocks * BLOCKSIZE;
638 _bytes_free -= blocks * BLOCKSIZE;
639 }
640
641 return result;
642}
643/* Free a block of memory allocated by `malloc'.
644 Copyright 1990, 1991, 1992 Free Software Foundation
645 Written May 1989 by Mike Haertel.
646
647This library is free software; you can redistribute it and/or
648modify it under the terms of the GNU Library General Public License as
649published by the Free Software Foundation; either version 2 of the
650License, or (at your option) any later version.
651
652This library is distributed in the hope that it will be useful,
653but WITHOUT ANY WARRANTY; without even the implied warranty of
654MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
655Library General Public License for more details.
656
657You should have received a copy of the GNU Library General Public
658License along with this library; see the file COPYING.LIB. If
659not, write to the Free Software Foundation, Inc., 675 Mass Ave,
660Cambridge, MA 02139, USA.
661
662 The author may be reached (Email) at the address mike@ai.mit.edu,
663 or (US mail) as Mike Haertel c/o Free Software Foundation. */
664
665#ifndef _MALLOC_INTERNAL
666#define _MALLOC_INTERNAL
667#include <malloc.h>
668#endif
669
670#ifdef VMS
671/* How to really get more memory. */
672__ptr_t (*__lesscore) __P ((__ptr_t __ptr,ptrdiff_t __size)) = __vms_lesscore;
673#else
674/* How to really get more memory. */
675__ptr_t (*__lesscore) __P ((__ptr_t __ptr,ptrdiff_t __size)) = __default_lesscore;
676#endif
677
678/* Debugging hook for free. */
679#ifdef VMS
680void (*__free_hook) __P ((__ptr_t __ptr)) = __vms_free;
681#else
682void (*__free_hook) __P ((__ptr_t __ptr));
683#endif
684
685/* List of blocks allocated by memalign. */
686struct alignlist *_aligned_blocks = NULL;
687
688/* Return memory to the heap.
689 Like `free' but don't call a __free_hook if there is one. */
690void
691_free_internal (ptr)
692 __ptr_t ptr;
693{
694 int type;
695 size_t block, blocks;
696 register size_t i;
697 struct list *prev, *next;
698
699 block = BLOCK (ptr);
700
701 type = _heapinfo[block].busy.type;
702 switch (type)
703 {
704 case 0:
705 /* Get as many statistics as early as we can. */
706 --_chunks_used;
707 _bytes_used -= _heapinfo[block].busy.info.size * BLOCKSIZE;
708 _bytes_free += _heapinfo[block].busy.info.size * BLOCKSIZE;
709
710 /* Find the free cluster previous to this one in the free list.
711 Start searching at the last block referenced; this may benefit
712 programs with locality of allocation. */
713 i = _heapindex;
714 if (i > block)
715 while (i > block)
716 i = _heapinfo[i].free.prev;
717 else
718 {
719 do
720 i = _heapinfo[i].free.next;
721 while (i > 0 && i < block);
722 i = _heapinfo[i].free.prev;
723 }
724
725 /* Determine how to link this block into the free list. */
726 if (block == i + _heapinfo[i].free.size)
727 {
728 /* Coalesce this block with its predecessor. */
729 _heapinfo[i].free.size += _heapinfo[block].busy.info.size;
730 block = i;
731 }
732 else
733 {
734 /* Really link this block back into the free list. */
735 _heapinfo[block].free.size = _heapinfo[block].busy.info.size;
736 _heapinfo[block].free.next = _heapinfo[i].free.next;
737 _heapinfo[block].free.prev = i;
738 _heapinfo[i].free.next = block;
739 _heapinfo[_heapinfo[block].free.next].free.prev = block;
740 ++_chunks_free;
741 }
742
743 /* Now that the block is linked in, see if we can coalesce it
744 with its successor (by deleting its successor from the list
745 and adding in its size). */
746 if (block + _heapinfo[block].free.size == _heapinfo[block].free.next)
747 {
748 _heapinfo[block].free.size
749 += _heapinfo[_heapinfo[block].free.next].free.size;
750 _heapinfo[block].free.next
751 = _heapinfo[_heapinfo[block].free.next].free.next;
752 _heapinfo[_heapinfo[block].free.next].free.prev = block;
753 --_chunks_free;
754 }
755
756 /* Now see if we can return stuff to the system. */
757 blocks = _heapinfo[block].free.size;
758 if (blocks >= FINAL_FREE_BLOCKS && block + blocks == _heaplimit
759 && (*__morecore) (0) == ADDRESS (block + blocks))
760 {
761 register size_t bytes = blocks * BLOCKSIZE;
762 _heaplimit -= blocks;
763 (*__lesscore) (ADDRESS(block), bytes);
764 _heapinfo[_heapinfo[block].free.prev].free.next
765 = _heapinfo[block].free.next;
766 _heapinfo[_heapinfo[block].free.next].free.prev
767 = _heapinfo[block].free.prev;
768 block = _heapinfo[block].free.prev;
769 --_chunks_free;
770 _bytes_free -= bytes;
771 }
772
773 /* Set the next search to begin at this block. */
774 _heapindex = block;
775 break;
776
777 default:
778 /* Do some of the statistics. */
779 --_chunks_used;
780 _bytes_used -= 1 << type;
781 ++_chunks_free;
782 _bytes_free += 1 << type;
783
784 /* Get the address of the first free fragment in this block. */
785 prev = (struct list *) ((char *) ADDRESS (block) +
786 (_heapinfo[block].busy.info.frag.first << type));
787#ifdef RL_DEBUG
788 printf("_free_internal(0%o/0x%x/%d) :\n", ptr, ptr, ptr);
789 printf(" block = %d, type = %d, prev = 0%o/0x%x/%d\n",
790 block, type, prev, prev, prev);
791 printf(" _heapinfo[block=%d].busy.info.frag.nfree = %d\n",
792 block,
793 _heapinfo[block].busy.info.frag.nfree);
794#endif
795
796 if (_heapinfo[block].busy.info.frag.nfree == (BLOCKSIZE >> type) - 1)
797 {
798 /* If all fragments of this block are free, remove them
799 from the fragment list and free the whole block. */
800 next = prev;
801 for (i = 1; i < (size_t) (BLOCKSIZE >> type); ++i)
802 next = next->next;
803 prev->prev->next = next;
804 if (next != NULL)
805 next->prev = prev->prev;
806 _heapinfo[block].busy.type = 0;
807 _heapinfo[block].busy.info.size = 1;
808
809 /* Keep the statistics accurate. */
810 ++_chunks_used;
811 _bytes_used += BLOCKSIZE;
812 _chunks_free -= BLOCKSIZE >> type;
813 _bytes_free -= BLOCKSIZE;
814
815 free (ADDRESS (block));
816 }
817 else if (_heapinfo[block].busy.info.frag.nfree != 0)
818 {
819 /* If some fragments of this block are free, link this
820 fragment into the fragment list after the first free
821 fragment of this block. */
822#ifdef RL_DEBUG
823 printf("There's a bug hiding here (%s:%d), so I will print some values\n", __FILE__, __LINE__);
824#endif
825 next = (struct list *) ptr;
826#ifdef RL_DEBUG
827 printf(" (struct list *)next (0%o / 0x%x / %d) ->\n", next, next, next);
828 printf(" next = 0%o / 0x%x / %d\n", next->next,next->next,next->next);
829 printf(" prev = 0%o / 0x%x / %d\n", next->prev,next->prev,next->prev);
830 printf(" (struct list *)prev (0%o / 0x%x / %d)->\n", prev, prev, prev);
831 printf(" next = 0%o / 0x%x / %d\n", prev->next,prev->next,prev->next);
832 printf(" prev = 0%o / 0x%x / %d\n", prev->prev,prev->prev,prev->prev);
833#endif
834 next->next = prev->next;
835 next->prev = prev;
836 prev->next = next;
837 if (next->next != NULL)
838 next->next->prev = next;
839 ++_heapinfo[block].busy.info.frag.nfree;
840 }
841 else
842 {
843 /* No fragments of this block are free, so link this
844 fragment into the fragment list and announce that
845 it is the first free fragment of this block. */
846 prev = (struct list *) ptr;
847 _heapinfo[block].busy.info.frag.nfree = 1;
848 _heapinfo[block].busy.info.frag.first = (unsigned long int)
849 ((unsigned long int) ((char *) ptr - (char *) NULL)
850 % BLOCKSIZE >> type);
851 prev->next = _fraghead[type].next;
852 prev->prev = &_fraghead[type];
853 prev->prev->next = prev;
854 if (prev->next != NULL)
855 prev->next->prev = prev;
856 }
857 break;
858 }
859}
860
861/* Return memory to the heap. */
862void
863free (ptr)
864 __ptr_t ptr;
865{
866 register struct alignlist *l;
867
868 if (ptr == NULL)
869 return;
870
871 for (l = _aligned_blocks; l != NULL; l = l->next)
872 if (l->aligned == ptr)
873 {
874 l->aligned = NULL; /* Mark the slot in the list as free. */
875 ptr = l->exact;
876 break;
877 }
878
879 if (__free_hook != NULL)
880 (*__free_hook) (ptr);
881 else
882 _free_internal (ptr);
883}
884/* Change the size of a block allocated by `malloc'.
885 Copyright 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
886 Written May 1989 by Mike Haertel.
887
888This library is free software; you can redistribute it and/or
889modify it under the terms of the GNU Library General Public License as
890published by the Free Software Foundation; either version 2 of the
891License, or (at your option) any later version.
892
893This library is distributed in the hope that it will be useful,
894but WITHOUT ANY WARRANTY; without even the implied warranty of
895MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
896Library General Public License for more details.
897
898You should have received a copy of the GNU Library General Public
899License along with this library; see the file COPYING.LIB. If
900not, write to the Free Software Foundation, Inc., 675 Mass Ave,
901Cambridge, MA 02139, USA.
902
903 The author may be reached (Email) at the address mike@ai.mit.edu,
904 or (US mail) as Mike Haertel c/o Free Software Foundation. */
905
906#ifndef _MALLOC_INTERNAL
907#define _MALLOC_INTERNAL
908#include <malloc.h>
909#endif
910
911#define min(A, B) ((A) < (B) ? (A) : (B))
912
913/* Debugging hook for realloc. */
914#ifdef VMS
915__ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, size_t __size)) = __vms_realloc;
916#else
917__ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, size_t __size));
918#endif
919
920/* Resize the given region to the new size, returning a pointer
921 to the (possibly moved) region. This is optimized for speed;
922 some benchmarks seem to indicate that greater compactness is
923 achieved by unconditionally allocating and copying to a
924 new region. This module has incestuous knowledge of the
925 internals of both free and malloc. */
926__ptr_t
927realloc (ptr, size)
928 __ptr_t ptr;
929 size_t size;
930{
931 __ptr_t result;
932 int type;
933 size_t block, blocks, oldlimit;
934
935 if (size == 0)
936 {
937 free (ptr);
938 return malloc (0);
939 }
940 else if (ptr == NULL)
941 return malloc (size);
942
943 if (__realloc_hook != NULL)
944 return (*__realloc_hook) (ptr, size);
945
946 block = BLOCK (ptr);
947
948 type = _heapinfo[block].busy.type;
949 switch (type)
950 {
951 case 0:
952 /* Maybe reallocate a large block to a small fragment. */
953 if (size <= BLOCKSIZE / 2)
954 {
955 result = malloc (size);
956 if (result != NULL)
957 {
958 memcpy (result, ptr, size);
959 free (ptr);
960 return result;
961 }
962 }
963
964 /* The new size is a large allocation as well;
965 see if we can hold it in place. */
966 blocks = BLOCKIFY (size);
967 if (blocks < _heapinfo[block].busy.info.size)
968 {
969 /* The new size is smaller; return
970 excess memory to the free list. */
971 _heapinfo[block + blocks].busy.type = 0;
972 _heapinfo[block + blocks].busy.info.size
973 = _heapinfo[block].busy.info.size - blocks;
974 _heapinfo[block].busy.info.size = blocks;
975 free (ADDRESS (block + blocks));
976 result = ptr;
977 }
978 else if (blocks == _heapinfo[block].busy.info.size)
979 /* No size change necessary. */
980 result = ptr;
981 else
982 {
983 /* Won't fit, so allocate a new region that will.
984 Free the old region first in case there is sufficient
985 adjacent free space to grow without moving. */
986 blocks = _heapinfo[block].busy.info.size;
987 /* Prevent free from actually returning memory to the system. */
988 oldlimit = _heaplimit;
989 _heaplimit = 0;
990 free (ptr);
991 _heaplimit = oldlimit;
992 result = malloc (size);
993 if (result == NULL)
994 {
995 /* Now we're really in trouble. We have to unfree
996 the thing we just freed. Unfortunately it might
997 have been coalesced with its neighbors. */
998 if (_heapindex == block)
999 (void) malloc (blocks * BLOCKSIZE);
1000 else
1001 {
1002 __ptr_t previous = malloc ((block - _heapindex) * BLOCKSIZE);
1003 (void) malloc (blocks * BLOCKSIZE);
1004 free (previous);
1005 }
1006 return NULL;
1007 }
1008 if (ptr != result)
1009 memmove (result, ptr, blocks * BLOCKSIZE);
1010 }
1011 break;
1012
1013 default:
1014 /* Old size is a fragment; type is logarithm
1015 to base two of the fragment size. */
1016 if (size > (size_t) (1 << (type - 1)) && size <= (size_t) (1 << type))
1017 /* The new size is the same kind of fragment. */
1018 result = ptr;
1019 else
1020 {
1021 /* The new size is different; allocate a new space,
1022 and copy the lesser of the new size and the old. */
1023 result = malloc (size);
1024 if (result == NULL)
1025 return NULL;
1026 memcpy (result, ptr, min (size, (size_t) 1 << type));
1027 free (ptr);
1028 }
1029 break;
1030 }
1031
1032 return result;
1033}
1034/* Copyright (C) 1991, 1992 Free Software Foundation, Inc.
1035
1036This library is free software; you can redistribute it and/or
1037modify it under the terms of the GNU Library General Public License as
1038published by the Free Software Foundation; either version 2 of the
1039License, or (at your option) any later version.
1040
1041This library is distributed in the hope that it will be useful,
1042but WITHOUT ANY WARRANTY; without even the implied warranty of
1043MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
1044Library General Public License for more details.
1045
1046You should have received a copy of the GNU Library General Public
1047License along with this library; see the file COPYING.LIB. If
1048not, write to the Free Software Foundation, Inc., 675 Mass Ave,
1049Cambridge, MA 02139, USA.
1050
1051 The author may be reached (Email) at the address mike@ai.mit.edu,
1052 or (US mail) as Mike Haertel c/o Free Software Foundation. */
1053
1054#ifndef _MALLOC_INTERNAL
1055#define _MALLOC_INTERNAL
1056#include <malloc.h>
1057#endif
1058
1059/* Allocate an array of NMEMB elements each SIZE bytes long.
1060 The entire array is initialized to zeros. */
1061__ptr_t
1062calloc (nmemb, size)
1063 register size_t nmemb;
1064 register size_t size;
1065{
1066 register __ptr_t result = malloc (nmemb * size);
1067
1068 if (result != NULL)
1069 (void) memset (result, 0, nmemb * size);
1070
1071 return result;
1072}
1073/* Copyright (C) 1991, 1992 Free Software Foundation, Inc.
1074This file is part of the GNU C Library.
1075
1076The GNU C Library is free software; you can redistribute it and/or modify
1077it under the terms of the GNU General Public License as published by
1078the Free Software Foundation; either version 2, or (at your option)
1079any later version.
1080
1081The GNU C Library is distributed in the hope that it will be useful,
1082but WITHOUT ANY WARRANTY; without even the implied warranty of
1083MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1084GNU General Public License for more details.
1085
1086You should have received a copy of the GNU General Public License
1087along with the GNU C Library; see the file COPYING. If not, write to
1088the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
1089
1090#ifndef _MALLOC_INTERNAL
1091#define _MALLOC_INTERNAL
1092#include <malloc.h>
1093#endif
1094
1095#ifndef __GNU_LIBRARY__
1096#define __sbrk sbrk
1097#ifdef VMS
1098#define __brk brk
1099#endif
1100#endif
1101
1102extern __ptr_t __sbrk __P ((int increment));
1103
1104#ifndef NULL
1105#define NULL 0
1106#endif
1107
1108#if defined(emacs) && defined(VMS)
1109/* Dumping of Emacs on VMS does not include the heap!
1110 So let's make a huge array from which initial data will be
1111 allocated.
1112
1113 VMS_ALLOCATION_SIZE is the amount of memory we preallocate.
1114 We don't want it to be too large, because it only gives a larger
1115 dump file. The way to check how much is really used is to
1116 make VMS_ALLOCATION_SIZE very large, to link Emacs with the
1117 debugger, run Emacs, check how much was allocated. Then set
1118 VMS_ALLOCATION_SIZE to something suitable, recompile gmalloc,
1119 relink Emacs, and you should be off.
1120
1121 N.B. This is experimental, but it worked quite fine on Emacs 18.
1122*/
1123#ifndef VMS_ALLOCATION_SIZE
1124#define VMS_ALLOCATION_SIZE (512*(512+128))
1125#endif
1126
1127int vms_out_initial = 0;
1128char vms_initial_buffer[VMS_ALLOCATION_SIZE];
1129char *vms_current_brk = vms_initial_buffer;
1130char *vms_end_brk = &vms_initial_buffer[VMS_ALLOCATION_SIZE-1];
1131
1132__ptr_t
1133__vms_initial_morecore (increment)
1134 ptrdiff_t increment;
1135{
1136 __ptr_t result = NULL;
1137 __ptr_t temp;
1138
1139 /* It's far easier to make the alignment here than to make a
1140 kludge in align () */
1141#ifdef RL_DEBUG
1142 printf(">>>foo... %p...", vms_current_brk);
1143#endif
1144 vms_current_brk += (BLOCKSIZE - ((unsigned long) vms_current_brk
1145 & (BLOCKSIZE - 1))) & (BLOCKSIZE - 1);
1146#ifdef RL_DEBUG
1147 printf("bar... %p. (%d)\n", vms_current_brk, increment);
1148#endif
1149 temp = vms_current_brk + (int) increment;
1150 if (temp <= vms_end_brk)
1151 {
1152 if (increment >= 0)
1153 result = vms_current_brk;
1154 else
1155 result = temp;
1156 vms_current_brk = temp;
1157 }
1158 return result;
1159}
1160
1161__ptr_t
1162__vms_initial_lesscore (ptr, size)
1163 __ptr_t ptr;
1164 ptrdiff_t size;
1165{
1166 if (ptr >= vms_initial_buffer
1167 && ptr < vms_initial_buffer+VMS_ALLOCATION_SIZE)
1168 {
1169 vms_current_brk = ptr;
1170 return vms_current_brk;
1171 }
1172 return vms_current_brk;
1173}
1174
1175VMS_present_buffer()
1176{
1177 printf("Vms initial buffer starts at 0%o/0x%x/%d and ends at 0%o/0x%x/%d\n",
1178 vms_initial_buffer, vms_initial_buffer, vms_initial_buffer,
1179 vms_end_brk, vms_end_brk, vms_end_brk);
1180}
1181#endif /* defined(emacs) && defined(VMS) */
1182
1183#ifdef VMS
1184/* Unfortunately, the VAX C sbrk() is buggy. For example, it returns
1185 memory in 512 byte chunks (not a bug, but there's more), AND it
1186 adds an extra 512 byte chunk if you ask for a multiple of 512
1187 bytes (you ask for 512 bytes, you get 1024 bytes...). And also,
1188 the VAX C sbrk does not handle negative increments...
1189 There's a similar problem with brk(). Even if you set the break
1190 to an even page boundary, it gives you one extra page... */
1191
1192static char vms_brk_info_fetched = -1; /* -1 if this is the first time, otherwise
1193 bit 0 set if 'increment' needs adjustment
1194 bit 1 set if the value to brk() needs adjustment */
1195static char *vms_brk_start = 0;
1196static char *vms_brk_end = 0;
1197static char *vms_brk_current = 0;
1198#endif
1199
1200/* Allocate INCREMENT more bytes of data space,
1201 and return the start of data space, or NULL on errors.
1202 If INCREMENT is negative, shrink data space. */
1203__ptr_t
1204__default_morecore (increment)
1205 ptrdiff_t increment;
1206{
1207 __ptr_t result;
1208#ifdef VMS
1209 __ptr_t temp;
1210
1211#ifdef RL_DEBUG
1212 printf("DEBUG: morecore: increment = %x\n", increment);
1213 printf(" @ start: vms_brk_info_fetched = %x\n", vms_brk_info_fetched);
1214 printf(" vms_brk_start = %p\n", vms_brk_start);
1215 printf(" vms_brk_current = %p\n", vms_brk_current);
1216 printf(" vms_brk_end = %p\n", vms_brk_end);
1217 printf(" @ end: ");
1218#endif
1219
1220 if (vms_brk_info_fetched < 0)
1221 {
1222 vms_brk_current = vms_brk_start = __sbrk (512);
1223 vms_brk_end = __sbrk (0);
1224 if (vms_brk_end - vms_brk_current == 1024)
1225 vms_brk_info_fetched = 1;
1226 else
1227 vms_brk_info_fetched = 0;
1228 vms_brk_end = brk(vms_brk_start);
1229 if (vms_brk_end != vms_brk_start)
1230 vms_brk_info_fetched |= 2;
1231#ifdef RL_DEBUG
1232 printf("vms_brk_info_fetched = %x\n", vms_brk_info_fetched);
1233 printf(" vms_brk_start = %p\n", vms_brk_start);
1234 printf(" vms_brk_current = %p\n", vms_brk_current);
1235 printf(" vms_brk_end = %p\n", vms_brk_end);
1236 printf(" ");
1237#endif
1238 }
1239
1240 if (increment < 0)
1241 {
1242 printf("BZZZZZT! ERROR: __default_morecore does NOT take negative args\n");
1243 return NULL;
1244 }
1245
1246 if (increment > 0)
1247 {
1248 result = vms_brk_current;
1249 temp = vms_brk_current + increment;
1250
1251 if (temp > vms_brk_end)
1252 {
1253 __ptr_t foo;
1254
1255 foo = __sbrk (0);
1256 if (foo == vms_brk_end)
1257 {
1258 increment = temp - vms_brk_end;
1259 if (increment > (vms_brk_info_fetched & 1))
1260 increment -= (vms_brk_info_fetched & 1);
1261 foo = __sbrk(increment);
1262#ifdef RL_DEBUG
1263 printf("__sbrk(%d) --> %p\n", increment, foo);
1264#endif
1265 if (foo == (__ptr_t) -1)
1266 return NULL;
1267#ifdef RL_DEBUG
1268 printf(" ");
1269#endif
1270 }
1271 else
1272 {
1273 result = __sbrk (increment);
1274
1275 if (result == (__ptr_t) -1)
1276 return NULL;
1277
1278 temp = result + increment;
1279 }
1280
1281 vms_brk_end = __sbrk(0);
1282 }
1283 vms_brk_current = temp;
1284#ifdef RL_DEBUG
1285 printf("vms_brk_current = %p\n", vms_brk_current);
1286 printf(" vms_brk_end = %p\n", vms_brk_end);
1287#endif
1288 return result;
1289 }
1290#ifdef RL_DEBUG
1291 printf(" nothing more...\n");
1292#endif
1293
1294 /* OK, so the user wanted to check where the heap limit is. Let's
1295 see if the system thinks it is where we think it is. */
1296 temp = __sbrk (0);
1297 if (temp != vms_brk_end)
1298 {
1299 /* the value has changed.
1300 Let's trust the system and modify our value */
1301 vms_brk_current = vms_brk_end = temp;
1302 }
1303 return vms_brk_current;
1304
1305#else /* not VMS */
1306 result = __sbrk ((int) increment);
1307 if (result == (__ptr_t) -1)
1308 return NULL;
1309 return result;
1310#endif /* VMS */
1311}
1312
1313__ptr_t
1314__default_lesscore (ptr, size)
1315 __ptr_t ptr;
1316 ptrdiff_t size;
1317{
1318#ifdef VMS
1319 if (vms_brk_end != 0)
1320 {
1321 vms_brk_current = ptr;
1322 if (vms_brk_current < vms_brk_start)
1323 vms_brk_current = vms_brk_start;
1324 vms_brk_end = (char *) vms_brk_current -
1325 ((vms_brk_info_fetched >> 1) & 1);
1326#ifdef RL_DEBUG
1327 printf("<<<bar... %p (%p (%p, %d))...",
1328 vms_brk_end, vms_brk_current, ptr, size);
1329#endif
1330 vms_brk_end = __brk (vms_brk_end);
1331#ifdef RL_DEBUG
1332 printf("foo... %p.\n", vms_brk_end);
1333#endif
1334 }
1335
1336 return vms_brk_current;
1337#else /* not VMS */
1338 __default_morecore (-size);
1339#endif
1340}
1341
1342/* Allocate memory on a page boundary.
1343 Copyright (C) 1991, 1992 Free Software Foundation, Inc.
1344
1345This library is free software; you can redistribute it and/or
1346modify it under the terms of the GNU Library General Public License as
1347published by the Free Software Foundation; either version 2 of the
1348License, or (at your option) any later version.
1349
1350This library is distributed in the hope that it will be useful,
1351but WITHOUT ANY WARRANTY; without even the implied warranty of
1352MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
1353Library General Public License for more details.
1354
1355You should have received a copy of the GNU Library General Public
1356License along with this library; see the file COPYING.LIB. If
1357not, write to the Free Software Foundation, Inc., 675 Mass Ave,
1358Cambridge, MA 02139, USA.
1359
1360 The author may be reached (Email) at the address mike@ai.mit.edu,
1361 or (US mail) as Mike Haertel c/o Free Software Foundation. */
1362
1363#ifndef _MALLOC_INTERNAL
1364#define _MALLOC_INTERNAL
1365#include <malloc.h>
1366#endif
1367
1368#if defined (emacs) || defined (HAVE_CONFIG_H)
1369#include "config.h"
1370#endif
1371
1372#ifdef __GNU_LIBRARY__
1373extern size_t __getpagesize __P ((void));
1374#else
1375#if !defined(USG) && !defined(VMS)
1376extern size_t getpagesize __P ((void));
1377#define __getpagesize() getpagesize()
1378#else
1379#include <sys/param.h>
1380#ifdef EXEC_PAGESIZE
1381#define __getpagesize() EXEC_PAGESIZE
1382#else /* No EXEC_PAGESIZE. */
1383#ifdef NBPG
1384#ifndef CLSIZE
1385#define CLSIZE 1
1386#endif /* No CLSIZE. */
1387#define __getpagesize() (NBPG * CLSIZE)
1388#else /* No NBPG. */
1389#define __getpagesize() NBPC
1390#endif /* NBPG. */
1391#endif /* EXEC_PAGESIZE. */
1392#endif /* USG. */
1393#endif
1394
1395static size_t pagesize;
1396
1397__ptr_t
1398valloc (size)
1399 size_t size;
1400{
1401 if (pagesize == 0)
1402 pagesize = __getpagesize ();
1403
1404 return memalign (pagesize, size);
1405}
1406/* Copyright (C) 1991, 1992 Free Software Foundation, Inc.
1407
1408This library is free software; you can redistribute it and/or
1409modify it under the terms of the GNU Library General Public License as
1410published by the Free Software Foundation; either version 2 of the
1411License, or (at your option) any later version.
1412
1413This library is distributed in the hope that it will be useful,
1414but WITHOUT ANY WARRANTY; without even the implied warranty of
1415MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
1416Library General Public License for more details.
1417
1418You should have received a copy of the GNU Library General Public
1419License along with this library; see the file COPYING.LIB. If
1420not, write to the Free Software Foundation, Inc., 675 Mass Ave,
1421Cambridge, MA 02139, USA. */
1422
1423#ifndef _MALLOC_INTERNAL
1424#define _MALLOC_INTERNAL
1425#include <malloc.h>
1426#endif
1427
1428__ptr_t
1429memalign (alignment, size)
1430 size_t alignment;
1431 size_t size;
1432{
1433 __ptr_t result;
1434 unsigned long int adj;
1435
1436 size = ((size + alignment - 1) / alignment) * alignment;
1437
1438 result = malloc (size);
1439 if (result == NULL)
1440 return NULL;
1441 adj = (unsigned long int) ((unsigned long int) ((char *) result -
1442 (char *) NULL)) % alignment;
1443 if (adj != 0)
1444 {
1445 struct alignlist *l;
1446 for (l = _aligned_blocks; l != NULL; l = l->next)
1447 if (l->aligned == NULL)
1448 /* This slot is free. Use it. */
1449 break;
1450 if (l == NULL)
1451 {
1452 l = (struct alignlist *) malloc (sizeof (struct alignlist));
1453 if (l == NULL)
1454 {
1455 free (result);
1456 return NULL;
1457 }
1458 }
1459 l->exact = result;
1460 result = l->aligned = (char *) result + alignment - adj;
1461 l->next = _aligned_blocks;
1462 _aligned_blocks = l;
1463 }
1464
1465 return result;
1466}
1467
1468#ifdef VMS
1469struct vms_malloc_data
1470{
1471 int __malloc_initialized;
1472 char *_heapbase;
1473 malloc_info *_heapinfo;
1474 size_t heapsize;
1475 size_t _heapindex;
1476 size_t _heaplimit;
1477 size_t _chunks_used;
1478 size_t _bytes_used;
1479 size_t _chunks_free;
1480 size_t _bytes_free;
1481} ____vms_malloc_data[] =
1482{
1483 { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 },
1484 { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }
1485};
1486
1487struct vms_core_routines
1488{
1489 __ptr_t (*__morecore) __P ((ptrdiff_t increment));
1490 __ptr_t (*__lesscore) __P ((__ptr_t address, ptrdiff_t increment));
1491} ____vms_core_routines[] =
1492{
1493 { __vms_initial_morecore, __vms_initial_lesscore },
1494 { __default_morecore, __default_lesscore },
1495 { 0, 0 }
1496};
1497
1498static int current_vms_data = -1;
1499static int current_vms_core_routines = 0;
1500
1501static void use_vms_core_routines (int i)
1502{
1503 current_vms_core_routines = i;
1504 current_vms_data = i;
1505}
1506
1507static void use_vms_data (int i)
1508{
1509 use_vms_core_routines (i);
1510 __malloc_initialized = ____vms_malloc_data[i].__malloc_initialized;
1511 _heapbase = ____vms_malloc_data[i]._heapbase;
1512 _heapinfo = ____vms_malloc_data[i]._heapinfo;
1513 heapsize = ____vms_malloc_data[i].heapsize;
1514 _heapindex = ____vms_malloc_data[i]._heapindex;
1515 _heaplimit = ____vms_malloc_data[i]._heaplimit;
1516 _chunks_used = ____vms_malloc_data[i]._chunks_used;
1517 _bytes_used = ____vms_malloc_data[i]._bytes_used;
1518 _chunks_free = ____vms_malloc_data[i]._chunks_free;
1519 _bytes_free = ____vms_malloc_data[i]._bytes_free;
1520}
1521
1522static void store_vms_data (int i)
1523{
1524 ____vms_malloc_data[i].__malloc_initialized = __malloc_initialized;
1525 ____vms_malloc_data[i]._heapbase = _heapbase;
1526 ____vms_malloc_data[i]._heapinfo = _heapinfo;
1527 ____vms_malloc_data[i].heapsize = heapsize;
1528 ____vms_malloc_data[i]._heapindex = _heapindex;
1529 ____vms_malloc_data[i]._heaplimit = _heaplimit;
1530 ____vms_malloc_data[i]._chunks_used = _chunks_used;
1531 ____vms_malloc_data[i]._bytes_used = _bytes_used;
1532 ____vms_malloc_data[i]._chunks_free = _chunks_free;
1533 ____vms_malloc_data[i]._bytes_free = _bytes_free;
1534}
1535
1536static void store_current_vms_data ()
1537{
1538 switch (current_vms_data)
1539 {
1540 case 0:
1541 case 1:
1542 store_vms_data (current_vms_data);
1543 break;
1544 }
1545}
1546
1547__ptr_t __vms_morecore (increment)
1548 ptrdiff_t increment;
1549{
1550 return
1551 (*____vms_core_routines[current_vms_core_routines].__morecore) (increment);
1552}
1553
1554__ptr_t __vms_lesscore (ptr, increment)
1555 __ptr_t ptr;
1556 ptrdiff_t increment;
1557{
1558 return
1559 (*____vms_core_routines[current_vms_core_routines].__lesscore) (ptr,increment);
1560}
1561
1562__ptr_t __vms_malloc (size)
1563 size_t size;
1564{
1565 __ptr_t result;
1566 int old_current_vms_data = current_vms_data;
1567
1568 __malloc_hook = 0;
1569
1570 store_current_vms_data ();
1571
1572 if (____vms_malloc_data[0]._heapbase != 0)
1573 use_vms_data (0);
1574 else
1575 use_vms_core_routines (0);
1576 result = malloc (size);
1577 store_vms_data (0);
1578 if (result == NULL)
1579 {
1580 use_vms_data (1);
1581 result = malloc (size);
1582 store_vms_data (1);
1583 vms_out_initial = 1;
1584 }
1585 __malloc_hook = __vms_malloc;
1586 if (old_current_vms_data != -1)
1587 use_vms_data (current_vms_data);
1588 return result;
1589}
1590
1591void __vms_free (ptr)
1592 __ptr_t ptr;
1593{
1594 int old_current_vms_data = current_vms_data;
1595
1596 __free_hook = 0;
1597
1598 store_current_vms_data ();
1599
1600 if (ptr >= vms_initial_buffer && ptr <= vms_end_brk)
1601 {
1602 use_vms_data (0);
1603 free (ptr);
1604 store_vms_data (0);
1605 }
1606 else
1607 {
1608 use_vms_data (1);
1609 free (ptr);
1610 store_vms_data (1);
1611 if (_chunks_free == 0 && _chunks_used == 0)
1612 vms_out_initial = 0;
1613 }
1614 __free_hook = __vms_free;
1615 if (old_current_vms_data != -1)
1616 use_vms_data (current_vms_data);
1617}
1618
1619__ptr_t __vms_realloc (ptr, size)
1620 __ptr_t ptr;
1621 size_t size;
1622{
1623 __ptr_t result;
1624 int old_current_vms_data = current_vms_data;
1625
1626 __realloc_hook = 0;
1627
1628 store_current_vms_data ();
1629
1630 if (ptr >= vms_initial_buffer && ptr <= vms_end_brk)
1631 {
1632 use_vms_data (0);
1633 result = realloc (ptr, size);
1634 store_vms_data (0);
1635 }
1636 else
1637 {
1638 use_vms_data (1);
1639 result = realloc (ptr, size);
1640 store_vms_data (1);
1641 }
1642 __realloc_hook = __vms_realloc;
1643 if (old_current_vms_data != -1)
1644 use_vms_data (current_vms_data);
1645 return result;
1646}
1647#endif /* VMS */
1648/* Standard debugging hooks for `malloc'.
1649 Copyright 1990, 1991, 1992 Free Software Foundation
1650 Written May 1989 by Mike Haertel.
1651
1652This library is free software; you can redistribute it and/or
1653modify it under the terms of the GNU Library General Public License as
1654published by the Free Software Foundation; either version 2 of the
1655License, or (at your option) any later version.
1656
1657This library is distributed in the hope that it will be useful,
1658but WITHOUT ANY WARRANTY; without even the implied warranty of
1659MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
1660Library General Public License for more details.
1661
1662You should have received a copy of the GNU Library General Public
1663License along with this library; see the file COPYING.LIB. If
1664not, write to the Free Software Foundation, Inc., 675 Mass Ave,
1665Cambridge, MA 02139, USA.
1666
1667 The author may be reached (Email) at the address mike@ai.mit.edu,
1668 or (US mail) as Mike Haertel c/o Free Software Foundation. */
1669
1670#ifndef _MALLOC_INTERNAL
1671#define _MALLOC_INTERNAL
1672#include <malloc.h>
1673#endif
1674
1675/* Old hook values. */
1676static void (*old_free_hook) __P ((__ptr_t ptr));
1677static __ptr_t (*old_malloc_hook) __P ((size_t size));
1678static __ptr_t (*old_realloc_hook) __P ((__ptr_t ptr, size_t size));
1679
1680/* Function to call when something awful happens. */
1681static void (*abortfunc) __P ((void));
1682
1683/* Arbitrary magical numbers. */
1684#define MAGICWORD 0xfedabeeb
1685#define MAGICBYTE ((char) 0xd7)
1686
1687struct hdr
1688 {
1689 size_t size; /* Exact size requested by user. */
1690 unsigned long int magic; /* Magic number to check header integrity. */
1691 };
1692
1693static void checkhdr __P ((__const struct hdr *));
1694static void
1695checkhdr (hdr)
1696 __const struct hdr *hdr;
1697{
1698 if (hdr->magic != MAGICWORD || ((char *) &hdr[1])[hdr->size] != MAGICBYTE)
1699 (*abortfunc) ();
1700}
1701
1702static void freehook __P ((__ptr_t));
1703static void
1704freehook (ptr)
1705 __ptr_t ptr;
1706{
1707 struct hdr *hdr = ((struct hdr *) ptr) - 1;
1708 checkhdr (hdr);
1709 hdr->magic = 0;
1710 __free_hook = old_free_hook;
1711 free (hdr);
1712 __free_hook = freehook;
1713}
1714
1715static __ptr_t mallochook __P ((size_t));
1716static __ptr_t
1717mallochook (size)
1718 size_t size;
1719{
1720 struct hdr *hdr;
1721
1722 __malloc_hook = old_malloc_hook;
1723 hdr = (struct hdr *) malloc (sizeof (struct hdr) + size + 1);
1724 __malloc_hook = mallochook;
1725 if (hdr == NULL)
1726 return NULL;
1727
1728 hdr->size = size;
1729 hdr->magic = MAGICWORD;
1730 ((char *) &hdr[1])[size] = MAGICBYTE;
1731 return (__ptr_t) (hdr + 1);
1732}
1733
1734static __ptr_t reallochook __P ((__ptr_t, size_t));
1735static __ptr_t
1736reallochook (ptr, size)
1737 __ptr_t ptr;
1738 size_t size;
1739{
1740 struct hdr *hdr = ((struct hdr *) ptr) - 1;
1741
1742 checkhdr (hdr);
1743 __free_hook = old_free_hook;
1744 __malloc_hook = old_malloc_hook;
1745 __realloc_hook = old_realloc_hook;
1746 hdr = (struct hdr *) realloc ((__ptr_t) hdr, sizeof (struct hdr) + size + 1);
1747 __free_hook = freehook;
1748 __malloc_hook = mallochook;
1749 __realloc_hook = reallochook;
1750 if (hdr == NULL)
1751 return NULL;
1752
1753 hdr->size = size;
1754 ((char *) &hdr[1])[size] = MAGICBYTE;
1755 return (__ptr_t) (hdr + 1);
1756}
1757
1758int
1759mcheck (func)
1760 void (*func) __P ((void));
1761{
1762 extern void abort __P ((void));
1763 static int mcheck_used = 0;
1764
1765 abortfunc = (func != NULL) ? func : abort;
1766
1767 /* These hooks may not be safely inserted if malloc is already in use. */
1768 if (!__malloc_initialized && !mcheck_used)
1769 {
1770 old_free_hook = __free_hook;
1771 __free_hook = freehook;
1772 old_malloc_hook = __malloc_hook;
1773 __malloc_hook = mallochook;
1774 old_realloc_hook = __realloc_hook;
1775 __realloc_hook = reallochook;
1776 mcheck_used = 1;
1777 }
1778
1779 return mcheck_used ? 0 : -1;
1780}
1781/* More debugging hooks for `malloc'.
1782 Copyright (C) 1991, 1992 Free Software Foundation, Inc.
1783 Written April 2, 1991 by John Gilmore of Cygnus Support.
1784 Based on mcheck.c by Mike Haertel.
1785
1786This library is free software; you can redistribute it and/or
1787modify it under the terms of the GNU Library General Public License as
1788published by the Free Software Foundation; either version 2 of the
1789License, or (at your option) any later version.
1790
1791This library is distributed in the hope that it will be useful,
1792but WITHOUT ANY WARRANTY; without even the implied warranty of
1793MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
1794Library General Public License for more details.
1795
1796You should have received a copy of the GNU Library General Public
1797License along with this library; see the file COPYING.LIB. If
1798not, write to the Free Software Foundation, Inc., 675 Mass Ave,
1799Cambridge, MA 02139, USA.
1800
1801 The author may be reached (Email) at the address mike@ai.mit.edu,
1802 or (US mail) as Mike Haertel c/o Free Software Foundation. */
1803
1804#ifndef _MALLOC_INTERNAL
1805#define _MALLOC_INTERNAL
1806#include <malloc.h>
1807#endif
1808
1809#include <stdio.h>
1810
1811#ifndef __GNU_LIBRARY__
1812extern char *getenv ();
1813#else
1814#include <stdlib.h>
1815#endif
1816
1817static FILE *mallstream;
1818static char mallenv[]= "MALLOC_TRACE";
1819static char mallbuf[BUFSIZ]; /* Buffer for the output. */
1820
1821/* Address to breakpoint on accesses to... */
1822__ptr_t mallwatch;
1823
1824/* Old hook values. */
1825static __ptr_t (*tr_old_morecore) __P ((ptrdiff_t increment));
1826static __ptr_t (*tr_old_lesscore) __P ((__ptr_t ptr, ptrdiff_t increment));
1827static void (*tr_old_free_hook) __P ((__ptr_t ptr));
1828static __ptr_t (*tr_old_malloc_hook) __P ((size_t size));
1829static __ptr_t (*tr_old_realloc_hook) __P ((__ptr_t ptr, size_t size));
1830
1831/* This function is called when the block being alloc'd, realloc'd, or
1832 freed has an address matching the variable "mallwatch". In a debugger,
1833 set "mallwatch" to the address of interest, then put a breakpoint on
1834 tr_break. */
1835
1836void tr_break __P ((void));
1837void
1838tr_break ()
1839{
1840}
1841
1842static void tr_freehook __P ((__ptr_t));
1843static void
1844tr_freehook (ptr)
1845 __ptr_t ptr;
1846{
1847 fprintf (mallstream, "- %p\n", ptr); /* Be sure to print it first. */
1848 if (ptr == mallwatch)
1849 tr_break ();
1850 __free_hook = tr_old_free_hook;
1851 free (ptr);
1852 __free_hook = tr_freehook;
1853}
1854
1855static __ptr_t tr_morecore __P ((ptrdiff_t));
1856static __ptr_t
1857tr_morecore (increment)
1858 ptrdiff_t increment;
1859{
1860 __ptr_t p;
1861
1862 __morecore = tr_old_morecore;
1863 p = (__ptr_t) (*__morecore) (increment);
1864 __morecore = tr_morecore;
1865
1866 fprintf (mallstream, "$ %p %d\n", p, increment);
1867
1868 return p;
1869}
1870
1871static __ptr_t tr_lesscore __P ((__ptr_t, ptrdiff_t));
1872static __ptr_t
1873tr_lesscore (ptr, increment)
1874 __ptr_t ptr;
1875 ptrdiff_t increment;
1876{
1877 __ptr_t p;
1878
1879 __lesscore = tr_old_lesscore;
1880 p = (__ptr_t) (*__lesscore) (ptr, increment);
1881 __lesscore = tr_lesscore;
1882
1883 fprintf (mallstream, "* %p (%p, %d)\n", p, ptr, increment);
1884
1885 return p;
1886}
1887
1888static __ptr_t tr_mallochook __P ((size_t));
1889static __ptr_t
1890tr_mallochook (size)
1891 size_t size;
1892{
1893 __ptr_t hdr;
1894
1895 __malloc_hook = tr_old_malloc_hook;
1896 hdr = (__ptr_t) malloc (size);
1897 __malloc_hook = tr_mallochook;
1898
1899 /* We could be printing a NULL here; that's OK. */
1900 fprintf (mallstream, "+ %p %x\n", hdr, size);
1901
1902 if (hdr == mallwatch)
1903 tr_break ();
1904
1905 return hdr;
1906}
1907
1908static __ptr_t tr_reallochook __P ((__ptr_t, size_t));
1909static __ptr_t
1910tr_reallochook (ptr, size)
1911 __ptr_t ptr;
1912 size_t size;
1913{
1914 __ptr_t hdr;
1915
1916 if (ptr == mallwatch)
1917 tr_break ();
1918
1919 __free_hook = tr_old_free_hook;
1920 __malloc_hook = tr_old_malloc_hook;
1921 __realloc_hook = tr_old_realloc_hook;
1922 hdr = (__ptr_t) realloc (ptr, size);
1923 __free_hook = tr_freehook;
1924 __malloc_hook = tr_mallochook;
1925 __realloc_hook = tr_reallochook;
1926 if (hdr == NULL)
1927 /* Failed realloc. */
1928 fprintf (mallstream, "! %p %x\n", ptr, size);
1929 else
1930 fprintf (mallstream, "< %p\n> %p %x\n", ptr, hdr, size);
1931
1932 if (hdr == mallwatch)
1933 tr_break ();
1934
1935 return hdr;
1936}
1937
1938/* We enable tracing if either the environment variable MALLOC_TRACE
1939 is set, or if the variable mallwatch has been patched to an address
1940 that the debugging user wants us to stop on. When patching mallwatch,
1941 don't forget to set a breakpoint on tr_break! */
1942
1943void
1944mtrace ()
1945{
1946 char *mallfile;
1947
1948 mallfile = getenv (mallenv);
1949 if (mallfile != NULL || mallwatch != NULL)
1950 {
1951 mallstream = fopen (mallfile != NULL ? mallfile : "/dev/null", "w");
1952 if (mallstream != NULL)
1953 {
1954 /* Be sure it doesn't malloc its buffer! */
1955 setbuf (mallstream, mallbuf);
1956 fprintf (mallstream, "= Start\n");
1957#if defined(emacs) && defined(VMS)
1958 fprintf (mallstream, "= Initial buffer spans %p -- %p\n",
1959 vms_initial_buffer, vms_end_brk + 1);
1960#endif
1961 tr_old_morecore = __morecore;
1962 __morecore = tr_morecore;
1963 tr_old_lesscore = __lesscore;
1964 __lesscore = tr_lesscore;
1965 tr_old_free_hook = __free_hook;
1966 __free_hook = tr_freehook;
1967 tr_old_malloc_hook = __malloc_hook;
1968 __malloc_hook = tr_mallochook;
1969 tr_old_realloc_hook = __realloc_hook;
1970 __realloc_hook = tr_reallochook;
1971 }
1972 }
1973}
1974/* Access the statistics maintained by `malloc'.
1975 Copyright 1990, 1991, 1992 Free Software Foundation
1976 Written May 1989 by Mike Haertel.
1977
1978This library is free software; you can redistribute it and/or
1979modify it under the terms of the GNU Library General Public License as
1980published by the Free Software Foundation; either version 2 of the
1981License, or (at your option) any later version.
1982
1983This library is distributed in the hope that it will be useful,
1984but WITHOUT ANY WARRANTY; without even the implied warranty of
1985MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
1986Library General Public License for more details.
1987
1988You should have received a copy of the GNU Library General Public
1989License along with this library; see the file COPYING.LIB. If
1990not, write to the Free Software Foundation, Inc., 675 Mass Ave,
1991Cambridge, MA 02139, USA.
1992
1993 The author may be reached (Email) at the address mike@ai.mit.edu,
1994 or (US mail) as Mike Haertel c/o Free Software Foundation. */
1995
1996#ifndef _MALLOC_INTERNAL
1997#define _MALLOC_INTERNAL
1998#include <malloc.h>
1999#endif
2000
2001struct mstats
2002mstats ()
2003{
2004 struct mstats result;
2005
2006 result.bytes_total = (char *) (*__morecore) (0) - _heapbase;
2007 result.chunks_used = _chunks_used;
2008 result.bytes_used = _bytes_used;
2009 result.chunks_free = _chunks_free;
2010 result.bytes_free = _bytes_free;
2011 return result;
2012}
diff --git a/src/vmsmap.c b/src/vmsmap.c
deleted file mode 100644
index 7d05c4bd263..00000000000
--- a/src/vmsmap.c
+++ /dev/null
@@ -1,225 +0,0 @@
1/* VMS mapping of data and alloc arena for GNU Emacs.
2 Copyright (C) 1986, 1987 Free Software Foundation, Inc.
3
4 This 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 2, 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, Inc., 59 Temple Place - Suite 330,
19Boston, MA 02111-1307, USA. */
20
21/* Written by Mukesh Prasad. */
22
23#ifdef VMS
24
25#include <config.h>
26#include "lisp.h"
27#include <rab.h>
28#include <fab.h>
29#include <rmsdef.h>
30#include <secdef.h>
31
32/* RMS block size */
33#define BLOCKSIZE 512
34
35/* Maximum number of bytes to be written in one RMS write.
36 * Must be a multiple of BLOCKSIZE.
37 */
38#define MAXWRITE (BLOCKSIZE * 30)
39
40/* This funniness is to ensure that sdata occurs alphabetically BEFORE the
41 $DATA psect and that edata occurs after ALL Emacs psects. This is
42 because the VMS linker sorts all psects in a cluster alphabetically
43 during the linking, unless you use the cluster_psect command. Emacs
44 uses the cluster command to group all Emacs psects into one cluster;
45 this keeps the dumped data separate from any loaded libraries. */
46
47globaldef {"$D$ATA"} char sdata[512]; /* Start of saved data area */
48globaldef {"__DATA"} char edata[512]; /* End of saved data area */
49
50/* Structure to write into first block of map file.
51 */
52
53struct map_data
54{
55 char * sdata; /* Start of data area */
56 char * edata; /* End of data area */
57 int datablk; /* Block in file to map data area from/to */
58};
59
60static void fill_fab (), fill_rab ();
61static int write_data ();
62
63extern char *start_of_data ();
64extern int vms_out_initial; /* Defined in malloc.c */
65
66/* Maps in the data and alloc area from the map file.
67 */
68
69int
70mapin_data (name)
71 char * name;
72{
73 struct FAB fab;
74 struct RAB rab;
75 int status, size;
76 int inadr[2];
77 struct map_data map_data;
78
79 /* Open map file. */
80 fab = cc$rms_fab;
81 fab.fab$b_fac = FAB$M_BIO|FAB$M_GET;
82 fab.fab$l_fna = name;
83 fab.fab$b_fns = strlen (name);
84 status = sys$open (&fab);
85 if (status != RMS$_NORMAL)
86 {
87 printf ("Map file not available, running bare Emacs....\n");
88 return 0; /* Map file not available */
89 }
90 /* Connect the RAB block */
91 rab = cc$rms_rab;
92 rab.rab$l_fab = &fab;
93 rab.rab$b_rac = RAB$C_SEQ;
94 rab.rab$l_rop = RAB$M_BIO;
95 status = sys$connect (&rab);
96 if (status != RMS$_NORMAL)
97 lib$stop (status);
98 /* Read the header data */
99 rab.rab$l_ubf = &map_data;
100 rab.rab$w_usz = sizeof (map_data);
101 rab.rab$l_bkt = 0;
102 status = sys$read (&rab);
103 if (status != RMS$_NORMAL)
104 lib$stop (status);
105 status = sys$close (&fab);
106 if (status != RMS$_NORMAL)
107 lib$stop (status);
108 if (map_data.sdata != start_of_data ())
109 {
110 printf ("Start of data area has moved: cannot map in data.\n");
111 return 0;
112 }
113 if (map_data.edata != edata)
114 {
115 printf ("End of data area has moved: cannot map in data.\n");
116 return 0;
117 }
118 fab.fab$l_fop |= FAB$M_UFO;
119 status = sys$open (&fab);
120 if (status != RMS$_NORMAL)
121 lib$stop (status);
122 /* Map data area. */
123 inadr[0] = map_data.sdata;
124 inadr[1] = map_data.edata;
125 status = sys$crmpsc (inadr, 0, 0, SEC$M_CRF | SEC$M_WRT, 0, 0, 0,
126 fab.fab$l_stv, 0, map_data.datablk, 0, 0);
127 if (! (status & 1))
128 lib$stop (status);
129}
130
131/* Writes the data and alloc area to the map file.
132 */
133mapout_data (into)
134 char * into;
135{
136 struct FAB fab;
137 struct RAB rab;
138 int status;
139 struct map_data map_data;
140 int datasize, msize;
141
142 if (vms_out_initial)
143 {
144 error ("Out of initial allocation. Must rebuild emacs with more memory (VMS_ALLOCATION_SIZE).");
145 return 0;
146 }
147 map_data.sdata = start_of_data ();
148 map_data.edata = edata;
149 datasize = map_data.edata - map_data.sdata + 1;
150 map_data.datablk = 2 + (sizeof (map_data) + BLOCKSIZE - 1) / BLOCKSIZE;
151 /* Create map file. */
152 fab = cc$rms_fab;
153 fab.fab$b_fac = FAB$M_BIO|FAB$M_PUT;
154 fab.fab$l_fna = into;
155 fab.fab$b_fns = strlen (into);
156 fab.fab$l_fop = FAB$M_CBT;
157 fab.fab$b_org = FAB$C_SEQ;
158 fab.fab$b_rat = 0;
159 fab.fab$b_rfm = FAB$C_VAR;
160 fab.fab$l_alq = 1 + map_data.datablk +
161 ((datasize + BLOCKSIZE - 1) / BLOCKSIZE);
162 status = sys$create (&fab);
163 if (status != RMS$_NORMAL)
164 {
165 error ("Could not create map file");
166 return 0;
167 }
168 /* Connect the RAB block */
169 rab = cc$rms_rab;
170 rab.rab$l_fab = &fab;
171 rab.rab$b_rac = RAB$C_SEQ;
172 rab.rab$l_rop = RAB$M_BIO;
173 status = sys$connect (&rab);
174 if (status != RMS$_NORMAL)
175 {
176 error ("RMS connect to map file failed");
177 return 0;
178 }
179 /* Write the header */
180 rab.rab$l_rbf = &map_data;
181 rab.rab$w_rsz = sizeof (map_data);
182 status = sys$write (&rab);
183 if (status != RMS$_NORMAL)
184 {
185 error ("RMS write (header) to map file failed");
186 return 0;
187 }
188 if (! write_data (&rab, map_data.datablk, map_data.sdata, datasize))
189 return 0;
190 status = sys$close (&fab);
191 if (status != RMS$_NORMAL)
192 {
193 error ("RMS close on map file failed");
194 return 0;
195 }
196 return 1;
197}
198
199static int
200write_data (rab, firstblock, data, length)
201 struct RAB * rab;
202 char * data;
203{
204 int status;
205
206 rab->rab$l_bkt = firstblock;
207 while (length > 0)
208 {
209 rab->rab$l_rbf = data;
210 rab->rab$w_rsz = length > MAXWRITE ? MAXWRITE : length;
211 status = sys$write (rab, 0, 0);
212 if (status != RMS$_NORMAL)
213 {
214 error ("RMS write to map file failed");
215 return 0;
216 }
217 data = &data[MAXWRITE];
218 length -= MAXWRITE;
219 rab->rab$l_bkt = 0;
220 }
221 return 1;
222} /* write_data */
223
224#endif /* VMS */
225
diff --git a/src/vmspaths.h b/src/vmspaths.h
deleted file mode 100644
index ae2d9ba4a5c..00000000000
--- a/src/vmspaths.h
+++ /dev/null
@@ -1,32 +0,0 @@
1/* Hey Emacs, this is -*- C -*- code! */
2
3/* The default search path for Lisp function "load".
4 This sets load-path. */
5#define PATH_LOADSEARCH "EMACS_LIBRARY:[LOCAL-LISP],EMACS_LIBRARY:[LISP]"
6
7/* Like PATH_LOADSEARCH, but used only when Emacs is dumping. This
8 path is usually identical to PATH_LOADSEARCH except that the entry
9 for the directory containing the installed lisp files has been
10 replaced with ../lisp. */
11#define PATH_DUMPLOADSEARCH "[-.LISP]"
12
13/* The extra search path for programs to invoke. This is appended to
14 whatever the PATH environment variable says to set the Lisp
15 variable exec-path and the first file name in it sets the Lisp
16 variable exec-directory. exec-directory is used for finding
17 executables and other architecture-dependent files. */
18#define PATH_EXEC "EMACS_LIBRARY:[LIB-SRC]"
19
20/* Where Emacs should look for its architecture-independent data
21 files, like the docstring file. The lisp variable data-directory
22 is set to this value. */
23#define PATH_DATA "EMACS_LIBRARY:[ETC]"
24
25/* the name of the directory that contains lock files
26 with which we record what files are being modified in Emacs.
27 This directory should be writable by everyone. */
28#define PATH_LOCK "EMACS_LIBRARY:[LOCK]"
29
30/* the name of the file !!!SuperLock!!! in the directory
31 specified by PATH_LOCK. Yes, this is redundant. */
32#define PATH_SUPERLOCK "EMACS_LIBRARY:[LOCK]$$$SUPERLOCK$$$."
diff --git a/src/vmsproc.c b/src/vmsproc.c
deleted file mode 100644
index d97396071b0..00000000000
--- a/src/vmsproc.c
+++ /dev/null
@@ -1,795 +0,0 @@
1/* Interfaces to subprocesses on VMS.
2 Copyright (C) 1988, 1994 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 2, 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, Inc., 59 Temple Place - Suite 330,
19Boston, MA 02111-1307, USA. */
20
21
22/*
23 Event flag and `select' emulation
24
25 0 is never used
26 1 is the terminal
27 23 is the timer event flag
28 24-31 are reserved by VMS
29*/
30#include <config.h>
31#include <ssdef.h>
32#include <iodef.h>
33#include <dvidef.h>
34#include <clidef.h>
35#include "vmsproc.h"
36#include "lisp.h"
37#include "buffer.h"
38#include <file.h>
39#include "process.h"
40#include "commands.h"
41#include <errno.h>
42extern Lisp_Object call_process_cleanup ();
43
44
45#define KEYBOARD_EVENT_FLAG 1
46#define TIMER_EVENT_FLAG 23
47
48static VMS_PROC_STUFF procList[MAX_EVENT_FLAGS+1];
49
50get_kbd_event_flag ()
51{
52 /*
53 Return the first event flag for keyboard input.
54 */
55 VMS_PROC_STUFF *vs = &procList[KEYBOARD_EVENT_FLAG];
56
57 vs->busy = 1;
58 vs->pid = 0;
59 return (vs->eventFlag);
60}
61
62get_timer_event_flag ()
63{
64 /*
65 Return the last event flag for use by timeouts
66 */
67 VMS_PROC_STUFF *vs = &procList[TIMER_EVENT_FLAG];
68
69 vs->busy = 1;
70 vs->pid = 0;
71 return (vs->eventFlag);
72}
73
74VMS_PROC_STUFF *
75get_vms_process_stuff ()
76{
77 /*
78 Return a process_stuff structure
79
80 We use 1-23 as our event flags to simplify implementing
81 a VMS `select' call.
82 */
83 int i;
84 VMS_PROC_STUFF *vs;
85
86 for (i=1, vs = procList; i<MAX_EVENT_FLAGS; i++, vs++)
87 {
88 if (!vs->busy)
89 {
90 vs->busy = 1;
91 vs->inputChan = 0;
92 vs->pid = 0;
93 sys$clref (vs->eventFlag);
94 return (vs);
95 }
96 }
97 return ((VMS_PROC_STUFF *)0);
98}
99
100give_back_vms_process_stuff (vs)
101 VMS_PROC_STUFF *vs;
102{
103 /*
104 Return an event flag to our pool
105 */
106 vs->busy = 0;
107 vs->inputChan = 0;
108 vs->pid = 0;
109}
110
111VMS_PROC_STUFF *
112get_vms_process_pointer (pid)
113 int pid;
114{
115 /*
116 Given a pid, return the VMS_STUFF pointer
117 */
118 int i;
119 VMS_PROC_STUFF *vs;
120
121 /* Don't search the last one */
122 for (i=0, vs=procList; i<MAX_EVENT_FLAGS; i++, vs++)
123 {
124 if (vs->busy && vs->pid == pid)
125 return (vs);
126 }
127 return ((VMS_PROC_STUFF *)0);
128}
129
130start_vms_process_read (vs)
131 VMS_PROC_STUFF *vs;
132{
133 /*
134 Start an asynchronous read on a VMS process
135 We will catch up with the output sooner or later
136 */
137 int status;
138 int ProcAst ();
139
140 status = sys$qio (vs->eventFlag, vs->outputChan, IO$_READVBLK,
141 vs->iosb, 0, vs,
142 vs->inputBuffer, sizeof (vs->inputBuffer), 0, 0, 0, 0);
143 if (status != SS$_NORMAL)
144 return (0);
145 else
146 return (1);
147}
148
149extern int waiting_for_ast; /* in sysdep.c */
150extern int timer_ef;
151extern int input_ef;
152
153select (nDesc, rdsc, wdsc, edsc, timeOut)
154 int nDesc;
155 int *rdsc;
156 int *wdsc;
157 int *edsc;
158 int *timeOut;
159{
160 /* Emulate a select call
161
162 We know that we only use event flags 1-23
163
164 timeout == 100000 & bit 0 set means wait on keyboard input until
165 something shows up. If timeout == 0, we just read the event
166 flags and return what we find. */
167
168 int nfds = 0;
169 int status;
170 int time[2];
171 int delta = -10000000;
172 int zero = 0;
173 int timeout = *timeOut;
174 unsigned long mask, readMask, waitMask;
175
176 if (rdsc)
177 readMask = *rdsc << 1; /* Unix mask is shifted over 1 */
178 else
179 readMask = 0; /* Must be a wait call */
180
181 sys$clref (KEYBOARD_EVENT_FLAG);
182 sys$setast (0); /* Block interrupts */
183 sys$readef (KEYBOARD_EVENT_FLAG, &mask); /* See what is set */
184 mask &= readMask; /* Just examine what we need */
185 if (mask == 0)
186 { /* Nothing set, we must wait */
187 if (timeout != 0)
188 { /* Not just inspecting... */
189 if (!(timeout == 100000 &&
190 readMask == (1 << KEYBOARD_EVENT_FLAG)))
191 {
192 lib$emul (&timeout, &delta, &zero, time);
193 sys$setimr (TIMER_EVENT_FLAG, time, 0, 1);
194 waitMask = readMask | (1 << TIMER_EVENT_FLAG);
195 }
196 else
197 waitMask = readMask;
198 if (waitMask & (1 << KEYBOARD_EVENT_FLAG))
199 {
200 sys$clref (KEYBOARD_EVENT_FLAG);
201 waiting_for_ast = 1; /* Only if reading from 0 */
202 }
203 sys$setast (1);
204 sys$wflor (KEYBOARD_EVENT_FLAG, waitMask);
205 sys$cantim (1, 0);
206 sys$readef (KEYBOARD_EVENT_FLAG, &mask);
207 if (readMask & (1 << KEYBOARD_EVENT_FLAG))
208 waiting_for_ast = 0;
209 }
210 }
211 sys$setast (1);
212
213 /*
214 Count number of descriptors that are ready
215 */
216 mask &= readMask;
217 if (rdsc)
218 *rdsc = (mask >> 1); /* Back to Unix format */
219 for (nfds = 0; mask; mask >>= 1)
220 {
221 if (mask & 1)
222 nfds++;
223 }
224 return (nfds);
225}
226
227#define MAX_BUFF 1024
228
229write_to_vms_process (vs, buf, len)
230 VMS_PROC_STUFF *vs;
231 char *buf;
232 int len;
233{
234 /*
235 Write something to a VMS process.
236
237 We have to map newlines to carriage returns for VMS.
238 */
239 char ourBuff[MAX_BUFF];
240 short iosb[4];
241 int status;
242 int in, out;
243
244 while (len > 0)
245 {
246 out = map_nl_to_cr (buf, ourBuff, len, MAX_BUFF);
247 status = sys$qiow (0, vs->inputChan, IO$_WRITEVBLK|IO$M_NOFORMAT,
248 iosb, 0, 0, ourBuff, out, 0, 0, 0, 0);
249 if (status != SS$_NORMAL || (status = iosb[0]) != SS$_NORMAL)
250 {
251 error ("Could not write to subprocess: %x", status);
252 return (0);
253 }
254 len -= out;
255 }
256 return (1);
257}
258
259static
260map_nl_to_cr (in, out, maxIn, maxOut)
261 char *in;
262 char *out;
263 int maxIn;
264 int maxOut;
265{
266 /*
267 Copy `in' to `out' remapping `\n' to `\r'
268 */
269 int c;
270 int o;
271
272 for (o=0; maxIn-- > 0 && o < maxOut; o++)
273 {
274 c = *in++;
275 *out++ = (c == '\n') ? '\r' : c;
276 }
277 return (o);
278}
279
280clean_vms_buffer (buf, len)
281 char *buf;
282 int len;
283{
284 /*
285 Sanitize output from a VMS subprocess
286 Strip CR's and NULLs
287 */
288 char *oBuf = buf;
289 char c;
290 int l = 0;
291
292 while (len-- > 0)
293 {
294 c = *buf++;
295 if (c == '\r' || c == '\0')
296 ;
297 else
298 {
299 *oBuf++ = c;
300 l++;
301 }
302 }
303 return (l);
304}
305
306/*
307 For the CMU PTY driver
308*/
309#define PTYNAME "PYA0:"
310
311get_pty_channel (inDevName, outDevName, inChannel, outChannel)
312 char *inDevName;
313 char *outDevName;
314 int *inChannel;
315 int *outChannel;
316{
317 int PartnerUnitNumber;
318 int status;
319 struct {
320 int l;
321 char *a;
322 } d;
323 struct {
324 short BufLen;
325 short ItemCode;
326 int *BufAddress;
327 int *ItemLength;
328 } g[2];
329
330 d.l = strlen (PTYNAME);
331 d.a = PTYNAME;
332 *inChannel = 0; /* Should be `short' on VMS */
333 *outChannel = 0;
334 *inDevName = *outDevName = '\0';
335 status = sys$assign (&d, inChannel, 0, 0);
336 if (status == SS$_NORMAL)
337 {
338 *outChannel = *inChannel;
339 g[0].BufLen = sizeof (PartnerUnitNumber);
340 g[0].ItemCode = DVI$_UNIT;
341 g[0].BufAddress = &PartnerUnitNumber;
342 g[0].ItemLength = (int *)0;
343 g[1].BufLen = g[1].ItemCode = 0;
344 status = sys$getdviw (0, *inChannel, 0, &g, 0, 0, 0, 0);
345 if (status == SS$_NORMAL)
346 {
347 sprintf (inDevName, "_TPA%d:", PartnerUnitNumber);
348 strcpy (outDevName, inDevName);
349 }
350 }
351 return (status);
352}
353
354VMSgetwd (buf)
355 char *buf;
356{
357 /*
358 Return the current directory
359 */
360 char curdir[256];
361 char *getenv ();
362 char *s;
363 short len;
364 int status;
365 struct
366 {
367 int l;
368 char *a;
369 } d;
370
371 s = getenv ("SYS$DISK");
372 if (s)
373 strcpy (buf, s);
374 else
375 *buf = '\0';
376
377 d.l = 255;
378 d.a = curdir;
379 status = sys$setddir (0, &len, &d);
380 if (status & 1)
381 {
382 curdir[len] = '\0';
383 strcat (buf, curdir);
384 }
385}
386
387static
388call_process_ast (vs)
389 VMS_PROC_STUFF *vs;
390{
391 sys$setef (vs->eventFlag);
392}
393
394void
395child_setup (in, out, err, new_argv, env)
396 int in, out, err;
397 register char **new_argv;
398 char **env;
399{
400 /* ??? I suspect that maybe this shouldn't be done on VMS. */
401#ifdef subprocesses
402 /* Close Emacs's descriptors that this process should not have. */
403 close_process_descs ();
404#endif
405
406 if (STRINGP (current_buffer->directory))
407 chdir (XSTRING (current_buffer->directory)->data);
408}
409
410DEFUN ("call-process", Fcall_process, Scall_process, 1, MANY, 0,
411 "Call PROGRAM synchronously in a separate process.\n\
412Program's input comes from file INFILE (nil means null device, `NLA0:').\n\
413Insert output in BUFFER before point; t means current buffer;\n\
414 nil for BUFFER means discard it; 0 means discard and don't wait.\n\
415Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.\n\
416Remaining arguments are strings passed as command arguments to PROGRAM.\n\
417This function waits for PROGRAM to terminate, unless BUFFER is 0;\n\
418if you quit, the process is killed.")
419 (nargs, args)
420 int nargs;
421 register Lisp_Object *args;
422{
423 Lisp_Object display, buffer, path;
424 char oldDir[512];
425 int inchannel, outchannel;
426 int len;
427 int call_process_ast ();
428 struct
429 {
430 int l;
431 char *a;
432 } dcmd, din, dout;
433 char inDevName[65];
434 char outDevName[65];
435 short iosb[4];
436 int status;
437 int SpawnFlags = CLI$M_NOWAIT;
438 VMS_PROC_STUFF *vs;
439 VMS_PROC_STUFF *get_vms_process_stuff ();
440 int fd[2];
441 int filefd;
442 register int pid;
443 char buf[1024];
444 int count = specpdl_ptr - specpdl;
445 register unsigned char **new_argv;
446 struct buffer *old = current_buffer;
447
448 CHECK_STRING (args[0], 0);
449
450 if (nargs <= 1 || NILP (args[1]))
451 args[1] = build_string ("NLA0:");
452 else
453 args[1] = Fexpand_file_name (args[1], current_buffer->directory);
454
455 CHECK_STRING (args[1], 1);
456
457 {
458 register Lisp_Object tem;
459 buffer = tem = args[2];
460 if (nargs <= 2)
461 buffer = Qnil;
462 else if (!(EQ (tem, Qnil) || EQ (tem, Qt)
463 || XFASTINT (tem) == 0))
464 {
465 buffer = Fget_buffer (tem);
466 CHECK_BUFFER (buffer, 2);
467 }
468 }
469
470 display = nargs >= 3 ? args[3] : Qnil;
471
472 {
473 /*
474 if (args[0] == "*dcl*" then we need to skip pas the "-c",
475 else args[0] is the program to run.
476 */
477 register int i;
478 int arg0;
479 int firstArg;
480
481 if (strcmp (XSTRING (args[0])->data, "*dcl*") == 0)
482 {
483 arg0 = 5;
484 firstArg = 6;
485 }
486 else
487 {
488 arg0 = 0;
489 firstArg = 4;
490 }
491 len = XSTRING (args[arg0])->size + 1;
492 for (i = firstArg; i < nargs; i++)
493 {
494 CHECK_STRING (args[i], i);
495 len += XSTRING (args[i])->size + 1;
496 }
497 new_argv = alloca (len);
498 strcpy (new_argv, XSTRING (args[arg0])->data);
499 for (i = firstArg; i < nargs; i++)
500 {
501 strcat (new_argv, " ");
502 strcat (new_argv, XSTRING (args[i])->data);
503 }
504 dcmd.l = len-1;
505 dcmd.a = new_argv;
506
507 status = get_pty_channel (inDevName, outDevName, &inchannel, &outchannel);
508 if (!(status & 1))
509 error ("Error getting PTY channel: %x", status);
510 if (INTEGERP (buffer))
511 {
512 dout.l = strlen ("NLA0:");
513 dout.a = "NLA0:";
514 }
515 else
516 {
517 dout.l = strlen (outDevName);
518 dout.a = outDevName;
519 }
520
521 vs = get_vms_process_stuff ();
522 if (!vs)
523 {
524 sys$dassgn (inchannel);
525 sys$dassgn (outchannel);
526 error ("Too many VMS processes");
527 }
528 vs->inputChan = inchannel;
529 vs->outputChan = outchannel;
530 }
531
532 filefd = open (XSTRING (args[1])->data, O_RDONLY, 0);
533 if (filefd < 0)
534 {
535 sys$dassgn (inchannel);
536 sys$dassgn (outchannel);
537 give_back_vms_process_stuff (vs);
538 report_file_error ("Opening process input file", Fcons (args[1], Qnil));
539 }
540 else
541 close (filefd);
542
543 din.l = XSTRING (args[1])->size;
544 din.a = XSTRING (args[1])->data;
545
546 /*
547 Start a read on the process channel
548 */
549 if (!INTEGERP (buffer))
550 {
551 start_vms_process_read (vs);
552 SpawnFlags = CLI$M_NOWAIT;
553 }
554 else
555 SpawnFlags = 0;
556
557 /*
558 On VMS we need to change the current directory
559 of the parent process before forking so that
560 the child inherit that directory. We remember
561 where we were before changing.
562 */
563 VMSgetwd (oldDir);
564 child_setup (0, 0, 0, 0, 0);
565 status = lib$spawn (&dcmd, &din, &dout, &SpawnFlags, 0, &vs->pid,
566 &vs->exitStatus, 0, call_process_ast, vs);
567 chdir (oldDir);
568
569 if (status != SS$_NORMAL)
570 {
571 sys$dassgn (inchannel);
572 sys$dassgn (outchannel);
573 give_back_vms_process_stuff (vs);
574 error ("Error calling LIB$SPAWN: %x", status);
575 }
576 pid = vs->pid;
577
578 if (INTEGERP (buffer))
579 {
580#ifndef subprocesses
581 wait_without_blocking ();
582#endif subprocesses
583 return Qnil;
584 }
585
586 if (!NILP (display) && INTERACTIVE)
587 prepare_menu_bars ();
588
589 record_unwind_protect (call_process_cleanup,
590 Fcons (make_number (fd[0]), make_number (pid)));
591
592
593 if (BUFFERP (buffer))
594 Fset_buffer (buffer);
595
596 immediate_quit = 1;
597 QUIT;
598
599 while (1)
600 {
601 sys$waitfr (vs->eventFlag);
602 if (vs->iosb[0] & 1)
603 {
604 immediate_quit = 0;
605 if (!NILP (buffer))
606 {
607 vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]);
608 InsCStr (vs->inputBuffer, vs->iosb[1]);
609 }
610 if (!NILP (display) && INTERACTIVE)
611 redisplay_preserve_echo_area (19);
612 immediate_quit = 1;
613 QUIT;
614 if (!start_vms_process_read (vs))
615 break; /* The other side went away */
616 }
617 else
618 break;
619 }
620
621 sys$dassgn (inchannel);
622 sys$dassgn (outchannel);
623 give_back_vms_process_stuff (vs);
624
625 /* Wait for it to terminate, unless it already has. */
626 wait_for_termination (pid);
627
628 immediate_quit = 0;
629
630 set_current_buffer (old);
631
632 return unbind_to (count, Qnil);
633}
634
635create_process (process, new_argv)
636 Lisp_Object process;
637 char *new_argv;
638{
639 int pid, inchannel, outchannel, forkin, forkout;
640 char old_dir[512];
641 char in_dev_name[65];
642 char out_dev_name[65];
643 short iosb[4];
644 int status;
645 int spawn_flags = CLI$M_NOWAIT;
646 int child_sig ();
647 struct {
648 int l;
649 char *a;
650 } din, dout, dprompt, dcmd;
651 VMS_PROC_STUFF *vs;
652 VMS_PROC_STUFF *get_vms_process_stuff ();
653
654 status = get_pty_channel (in_dev_name, out_dev_name, &inchannel, &outchannel);
655 if (!(status & 1))
656 {
657 remove_process (process);
658 error ("Error getting PTY channel: %x", status);
659 }
660 dout.l = strlen (out_dev_name);
661 dout.a = out_dev_name;
662 dprompt.l = strlen (DCL_PROMPT);
663 dprompt.a = DCL_PROMPT;
664
665 if (strcmp (new_argv, "*dcl*") == 0)
666 {
667 din.l = strlen (in_dev_name);
668 din.a = in_dev_name;
669 dcmd.l = 0;
670 dcmd.a = (char *)0;
671 }
672 else
673 {
674 din.l = strlen ("NLA0:");
675 din.a = "NLA0:";
676 dcmd.l = strlen (new_argv);
677 dcmd.a = new_argv;
678 }
679
680 /* Delay interrupts until we have a chance to store
681 the new fork's pid in its process structure */
682 sys$setast (0);
683
684 vs = get_vms_process_stuff ();
685 if (vs == 0)
686 {
687 sys$setast (1);
688 remove_process (process);
689 error ("Too many VMS processes");
690 }
691 vs->inputChan = inchannel;
692 vs->outputChan = outchannel;
693
694 /* Start a read on the process channel */
695 start_vms_process_read (vs);
696
697 /* Switch current directory so that the child inherits it. */
698 VMSgetwd (old_dir);
699 child_setup (0, 0, 0, 0, 0);
700
701 status = lib$spawn (&dcmd, &din, &dout, &spawn_flags, 0, &vs->pid,
702 &vs->exitStatus, 0, child_sig, vs, &dprompt);
703 chdir (old_dir);
704
705 if (status != SS$_NORMAL)
706 {
707 sys$setast (1);
708 remove_process (process);
709 error ("Error calling LIB$SPAWN: %x", status);
710 }
711 vs->pid &= 0xffff; /* It needs to fit in a FASTINT,
712 we don't need the rest of the bits */
713 pid = vs->pid;
714
715 /*
716 ON VMS process->infd holds the (event flag-1)
717 that we use for doing I/O on that process.
718 `input_wait_mask' is the cluster of event flags
719 we can wait on.
720
721 Event flags returned start at 1 for the keyboard.
722 Since Unix expects descriptor 0 for the keyboard,
723 we subtract one from the event flag.
724 */
725 inchannel = vs->eventFlag-1;
726
727 /* Record this as an active process, with its channels.
728 As a result, child_setup will close Emacs's side of the pipes. */
729 chan_process[inchannel] = process;
730 XSETFASTINT (XPROCESS (process)->infd, inchannel);
731 XSETFASTINT (XPROCESS (process)->outfd, outchannel);
732 XPROCESS (process)->status = Qrun
733
734 /* Delay interrupts until we have a chance to store
735 the new fork's pid in its process structure */
736
737#define NO_ECHO "set term/noecho\r"
738 sys$setast (0);
739 /*
740 Send a command to the process to not echo input
741
742 The CMU PTY driver does not support SETMODEs.
743 */
744 write_to_vms_process (vs, NO_ECHO, strlen (NO_ECHO));
745
746 XSETFASTINT (XPROCESS (process)->pid, pid);
747 sys$setast (1);
748}
749
750child_sig (vs)
751 VMS_PROC_STUFF *vs;
752{
753 register int pid;
754 Lisp_Object tail, proc;
755 register struct Lisp_Process *p;
756 int old_errno = errno;
757
758 pid = vs->pid;
759 sys$setef (vs->eventFlag);
760
761 for (tail = Vprocess_alist; ! NILP (tail); tail = XCDR (tail))
762 {
763 proc = XCDR (XCAR (tail));
764 p = XPROCESS (proc);
765 if (EQ (p->childp, Qt) && XFASTINT (p->pid) == pid)
766 break;
767 }
768
769 if (NILP (tail))
770 return;
771
772 p->status = Fcons (Qexit, Fcons (make_number (vs->exitStatus), Qnil))
773}
774
775syms_of_vmsproc ()
776{
777 defsubr (&Scall_process);
778}
779
780init_vmsproc ()
781{
782 char *malloc ();
783 int i;
784 VMS_PROC_STUFF *vs;
785
786 for (vs=procList, i=0; i<MAX_EVENT_FLAGS+1; i++, vs++)
787 {
788 vs->busy = 0;
789 vs->eventFlag = i;
790 sys$clref (i);
791 vs->inputChan = 0;
792 vs->pid = 0;
793 }
794 procList[0].busy = 1; /* Zero is reserved */
795}
diff --git a/src/vmsproc.h b/src/vmsproc.h
deleted file mode 100644
index f6faddf6a3e..00000000000
--- a/src/vmsproc.h
+++ /dev/null
@@ -1,21 +0,0 @@
1/*
2 Structure for storing VMS specific information for an EMACS process
3
4 We use the event flags 1-23 for processes, keyboard input and timer
5*/
6
7/*
8 Same as MAXDESC in process.c
9*/
10#define MAX_EVENT_FLAGS 23
11
12typedef struct {
13 char inputBuffer[1024];
14 short inputChan;
15 short outputChan;
16 short busy;
17 int pid;
18 int eventFlag;
19 int exitStatus;
20 short iosb[4];
21} VMS_PROC_STUFF;
diff --git a/src/vmstime.c b/src/vmstime.c
deleted file mode 100644
index 4eec5d0a4de..00000000000
--- a/src/vmstime.c
+++ /dev/null
@@ -1,377 +0,0 @@
1/* Time support for VMS.
2 Copyright (C) 1993 Free Software Foundation.
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 2, 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, Inc., 59 Temple Place - Suite 330,
19Boston, MA 02111-1307, USA. */
20
21#include <config.h>
22#include "vmstime.h"
23
24long timezone=0;
25int daylight=0;
26
27static char tzname_default[20]="";
28static char tzname_dst[20]="";
29
30char *tzname[2] = { tzname_default, tzname_dst };
31
32static long internal_daylight=0;
33static char daylight_set=0;
34
35static long read_time(const char *nptr, const char **endptr,
36 int sign_allowed_p)
37{
38 int t;
39
40 *endptr = nptr;
41
42 /* This routine trusts the user very much, and does no checks!
43 The only exception is this: */
44 if (!sign_allowed_p && (*nptr == '-' || *nptr == '+'))
45 return 0;
46
47 t = strtol(*endptr, endptr, 10) * 3600;
48 if (**endptr != ':' || **endptr == '+' || **endptr == '-')
49 return t;
50 (*endptr)++;
51
52 t = t + strtol(*endptr, endptr, 10) * 60;
53 if (**endptr != ':' || **endptr == '+' || **endptr == '-')
54 return t;
55 (*endptr)++;
56
57 return t + strtol(*endptr, endptr, 10);
58}
59
60static void read_dst_time(const char *nptr, const char **endptr,
61 int *m, int *n, int *d,
62 int *leap_p)
63{
64 time_t bintim = time(0);
65 struct tm *lc = localtime(&bintim);
66
67 *leap_p = 1;
68 *m = 0; /* When m and n are 0, a Julian */
69 *n = 0; /* date has been inserted in d */
70
71 switch(*nptr)
72 {
73 case 'M':
74 {
75 /* This routine counts on the user to have specified "Mm.n.d",
76 where 1 <= n <= 5, 1 <= m <= 12, 0 <= d <= 6 */
77
78 *m = strtol(++nptr, endptr, 10);
79 (*endptr)++; /* Skip the dot */
80 *n = strtol(*endptr, endptr, 10);
81 (*endptr)++; /* Skip the dot */
82 *d = strtol(*endptr, endptr, 10);
83
84 return;
85 }
86 case 'J':
87 *leap_p = 0; /* Never count with leap years */
88 default: /* trust the user to have inserted a number! */
89 *d = strtol(++nptr, endptr, 10);
90 return;
91 }
92}
93
94struct vms_vectim
95{
96 short year, month, day, hour, minute, second, centi_second;
97};
98static void find_dst_time(int m, int n, long d,
99 int hour, int minute, int second,
100 int leap_p,
101 long vms_internal_time[2])
102{
103 long status = SYS$GETTIM(vms_internal_time);
104 struct vms_vectim vms_vectime;
105 status = SYS$NUMTIM(&vms_vectime, vms_internal_time);
106
107 if (m == 0 && n == 0)
108 {
109 long tmp_vms_internal_time[2][2];
110 long day_of_year;
111 long tmp_operation = LIB$K_DAY_OF_YEAR;
112
113 status = LIB$CVT_FROM_INTERNAL_TIME(&tmp_operation, &day_of_year,
114 vms_internal_time);
115
116 vms_vectime.month = 2;
117 vms_vectime.day = 29;
118 status = LIB$CVT_VECTIM(&vms_vectime, tmp_vms_internal_time[0]);
119 if (status & 1) /* This is a leap year */
120 {
121 if (!leap_p && d > 59)
122 d ++; /* If we don't count with 29th Feb,
123 and this is a leap year, count up,
124 to make day 60 really become the
125 1st March. */
126 }
127 /* 1st January, at midnight */
128 vms_vectime.month = 1;
129 vms_vectime.day = 1;
130 vms_vectime.hour = hour;
131 vms_vectime.minute = minute;
132 vms_vectime.second = second;
133 vms_vectime.centi_second = 0;
134 status = LIB$CVT_VECTIM(&vms_vectime, tmp_vms_internal_time[0]);
135 tmp_operation = LIB$K_DELTA_DAYS;
136 status = LIB$CVT_TO_INTERNAL_TIME(&tmp_operation, &d,
137 tmp_vms_internal_time[1]);
138 /* now, tmp_vms_interval_time[0] contains 1st Jan, 00:00:00,
139 and tmp_vms_interval_time[1] contains delta time +d days.
140 Let's just add them together */
141 status = LIB$ADD_TIMES(tmp_vms_internal_time[0],
142 tmp_vms_internal_time[1],
143 vms_internal_time);
144 }
145 else
146 {
147 long tmp_vms_internal_time[2];
148 long day_of_week;
149 long tmp_operation = LIB$K_DAY_OF_YEAR;
150
151 if (d == 0) /* 0 is Sunday, which isn't compatible with VMS,
152 where day_of_week is 1 -- 7, and 1 is Monday */
153 {
154 d = 7; /* So a simple conversion is required */
155 }
156 vms_vectime.month = m;
157 vms_vectime.day = 1;
158 vms_vectime.hour = hour;
159 vms_vectime.minute = minute;
160 vms_vectime.second = second;
161 vms_vectime.centi_second = 0;
162 status = LIB$CVT_VECTIM(&vms_vectime, tmp_vms_internal_time);
163 tmp_operation = LIB$K_DAY_OF_WEEK;
164 status = LIB$CVT_FROM_INTERNAL_TIME(&tmp_operation, &day_of_week,
165 tmp_vms_internal_time);
166 d -= day_of_week;
167 if (d < 0)
168 {
169 d += 7;
170 }
171 vms_vectime.day += (n-1)*7 + d;
172 status = LIB$CVT_VECTIM(&vms_vectime, vms_internal_time);
173 if (!(status & 1))
174 {
175 vms_vectime.day -= 7; /* n was probably 5 */
176 status = LIB$CVT_VECTIM(&vms_vectime, vms_internal_time);
177 }
178 }
179}
180
181static cmp_vms_internal_times(long vms_internal_time1[2],
182 long vms_internal_time2[2])
183{
184 if (vms_internal_time1[1] < vms_internal_time2[1])
185 return -1;
186 else
187 if (vms_internal_time1[1] > vms_internal_time2[1])
188 return 1;
189
190 if (vms_internal_time1[0] < vms_internal_time2[0])
191 return -1;
192 else
193 if (vms_internal_time1[0] > vms_internal_time2[0])
194 return 1;
195
196 return 0;
197}
198
199/* -------------------------- Global routines ------------------------------ */
200
201#ifdef tzset
202#undef tzset
203#endif
204void sys_tzset()
205{
206 char *TZ;
207 char *p, *q;
208
209 if (daylight_set)
210 return;
211
212 daylight = 0;
213
214 if ((TZ = getenv("TZ")) == 0)
215 return;
216
217 p = TZ;
218 q = tzname[0];
219
220 while(*p != '\0'
221 && (*p <'0' || *p > '9') && *p != '-' && *p != '+' && *p != ',')
222 *q++ = *p++;
223 *q = '\0';
224
225 /* This is special for VMS, so I don't care if it doesn't exist anywhere
226 else */
227
228 timezone = read_time(p, &p, 1);
229
230 q = tzname[1];
231
232 while(*p != '\0'
233 && (*p <'0' || *p > '9') && *p != '-' && *p != '+' && *p != ',')
234 *q++ = *p++;
235 *q = '\0';
236
237 if (*p != '-' && *p != '+' && !(*p >='0' && *p <= '9'))
238 internal_daylight = timezone - 3600;
239 else
240 internal_daylight = read_time(p, &p, 1);
241
242 if (*p == ',')
243 {
244 int start_m;
245 int start_n;
246 int start_d;
247 int start_leap_p;
248 int start_hour=2, start_minute=0, start_second=0;
249
250 p++;
251 read_dst_time(p, &p, &start_m, &start_n, &start_d, &start_leap_p);
252 if (*p == '/')
253 {
254 long tmp = read_time (++p, &p, 0);
255 start_hour = tmp / 3600;
256 start_minute = (tmp % 3600) / 60;
257 start_second = tmp % 60;
258 }
259 if (*p == ',')
260 {
261 int end_m;
262 int end_n;
263 int end_d;
264 int end_leap_p;
265 int end_hour=2, end_minute=0, end_second=0;
266
267 p++;
268 read_dst_time(p, &p, &end_m, &end_n, &end_d, &end_leap_p);
269 if (*p == '/')
270 {
271 long tmp = read_time (++p, &p, 0);
272 end_hour = tmp / 3600;
273 end_minute = (tmp % 3600) / 60;
274 end_second = tmp % 60;
275 }
276 {
277 long vms_internal_time[3][2];
278 find_dst_time(start_m, start_n, start_d,
279 start_hour, start_minute, start_second,
280 start_leap_p,
281 vms_internal_time[0]);
282 SYS$GETTIM(&vms_internal_time[1]);
283 find_dst_time(end_m, end_n, end_d,
284 end_hour, end_minute, end_second,
285 end_leap_p,
286 vms_internal_time[2]);
287 if (cmp_vms_internal_times(vms_internal_time[0],
288 vms_internal_time[1]) < 0
289 && cmp_vms_internal_times(vms_internal_time[1],
290 vms_internal_time[2]) < 0)
291 daylight = 1;
292 }
293 }
294 }
295}
296
297#ifdef localtime
298#undef localtime
299#endif
300struct tm *sys_localtime(time_t *clock)
301{
302 struct tm *tmp = localtime(clock);
303
304 sys_tzset();
305 tmp->tm_isdst = daylight;
306
307 return tmp;
308}
309
310#ifdef gmtime
311#undef gmtime
312#endif
313struct tm *sys_gmtime(time_t *clock)
314{
315 static struct tm gmt;
316 struct vms_vectim tmp_vectime;
317 long vms_internal_time[3][2];
318 long tmp_operation = LIB$K_DELTA_SECONDS;
319 long status;
320 long tmp_offset;
321 char tmp_o_sign;
322
323 sys_tzset();
324
325 if (daylight)
326 tmp_offset = internal_daylight;
327 else
328 tmp_offset = timezone;
329
330 if (tmp_offset < 0)
331 {
332 tmp_o_sign = -1;
333 tmp_offset = -tmp_offset;
334 }
335 else
336 tmp_o_sign = 1;
337
338 status = LIB$CVT_TO_INTERNAL_TIME(&tmp_operation, &tmp_offset,
339 vms_internal_time[1]);
340 status = SYS$GETTIM(vms_internal_time[0]);
341 if (tmp_o_sign < 0)
342 {
343 status = LIB$SUB_TIMES(vms_internal_time[0],
344 vms_internal_time[1],
345 vms_internal_time[2]);
346 }
347 else
348 {
349 status = LIB$ADD_TIMES(vms_internal_time[0],
350 vms_internal_time[1],
351 vms_internal_time[2]);
352 }
353
354 status = SYS$NUMTIM(&tmp_vectime, vms_internal_time[2]);
355 gmt.tm_sec = tmp_vectime.second;
356 gmt.tm_min = tmp_vectime.minute;
357 gmt.tm_hour = tmp_vectime.hour;
358 gmt.tm_mday = tmp_vectime.day;
359 gmt.tm_mon = tmp_vectime.month - 1;
360 gmt.tm_year = tmp_vectime.year - 1900;
361
362 tmp_operation = LIB$K_DAY_OF_WEEK;
363 status = LIB$CVT_FROM_INTERNAL_TIME(&tmp_operation,
364 &gmt.tm_wday,
365 vms_internal_time[2]);
366 if (gmt.tm_wday == 7) gmt.tm_wday = 0;
367
368 tmp_operation = LIB$K_DAY_OF_YEAR;
369 status = LIB$CVT_FROM_INTERNAL_TIME(&tmp_operation,
370 &gmt.tm_yday,
371 vms_internal_time[2]);
372 gmt.tm_yday--;
373 gmt.tm_isdst = daylight;
374
375 return &gmt;
376}
377
diff --git a/src/vmstime.h b/src/vmstime.h
deleted file mode 100644
index c7198d755b9..00000000000
--- a/src/vmstime.h
+++ /dev/null
@@ -1,35 +0,0 @@
1/* Interface to time support for VMS.
2 Copyright (C) 1993 Free Software Foundation.
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 2, 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, Inc., 59 Temple Place - Suite 330,
19Boston, MA 02111-1307, USA. */
20
21#ifndef vmstime_h
22#define vmstime_h
23
24#include <time.h>
25#include <libdtdef.h>
26
27extern long timezone;
28extern int daylight;
29extern char *tzname[2];
30
31void sys_tzset();
32struct tm *sys_localtime(time_t *clock);
33struct tm *sys_gmtime(time_t *clock);
34
35#endif /* vmstime_h */
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-19 16:36:24 +0000