Mercurial > emacs
changeset 36284:57b4ef5b9089
*** empty log message ***
| author | Gerd Moellmann <gerd@gnu.org> |
|---|---|
| date | Thu, 22 Feb 2001 12:01:57 +0000 |
| parents | 7eede723f9ed |
| children | df398b248a30 |
| files | lisp/ChangeLog src/ChangeLog src/unexencap.c src/unexfx2800.c src/vms-pp.c src/vms-pp.trans src/vms-pwd.h src/vmsdir.h src/vmsfns.c src/vmsgmalloc.c src/vmsmap.c src/vmspaths.h src/vmsproc.c src/vmsproc.h src/vmstime.c src/vmstime.h |
| diffstat | 16 files changed, 16 insertions(+), 4977 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Thu Feb 22 11:56:33 2001 +0000 +++ b/lisp/ChangeLog Thu Feb 22 12:01:57 2001 +0000 @@ -1,3 +1,15 @@ +2001-02-22 Gerd Moellmann <gerd@gnu.org> + + * startup.el (fancy-splash-text): Add a line for ordering + manuals. Reverse order of splash screens shown. + (use-fancy-splash-screens-p): Adapt to the text line added. + + * menu-bar.el (menu-bar-help-menu): Add an item for ordering + manuals from the FSF. + + * help.el (view-order-manuals): New function. + (toplevel): Bind C-h C-m to this function. + 2001-02-21 Stefan Monnier <monnier@cs.yale.edu> * newcomment.el (comment-forward): Skip the comment-start before
--- a/src/ChangeLog Thu Feb 22 11:56:33 2001 +0000 +++ b/src/ChangeLog Thu Feb 22 12:01:57 2001 +0000 @@ -1,5 +1,9 @@ 2001-02-22 Gerd Moellmann <gerd@gnu.org> + * vms-pp.c, vmsdir.h, vmsmap.c, vmsproc.h, vms-pp.trans, vmsfns.c, + * vmspaths.h, vmstime.c, vms-pwd.h, vmsgmalloc.c, vmsproc.c, + * vmstime.h: Files removed. + * unexencap.c, unexfx2800.c: Files removed. * dispnew.c (direct_output_for_insert): Give up if we are showing
--- a/src/unexencap.c Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,116 +0,0 @@ -/* Waiting for papers! */ - -/* - * Do an unexec() for coff encapsulation. Uses the approach I took - * for AKCL, so don't be surprised if it doesn't look too much like - * the other unexec() routines. Assumes NO_REMAP. Should be easy to - * adapt to the emacs style unexec() if that is desired, but this works - * just fine for me with GCC/GAS/GLD under System V. - Jordan - */ - -#include <sys/types.h> -#include <sys/fcntl.h> -#include <sys/file.h> -#include <stdio.h> -#include "/usr/gnu/lib/gcc/gcc-include/a.out.h" - -filecpy(to, from, n) -FILE *to, *from; -register int n; -{ - char buffer[BUFSIZ]; - - for (;;) - if (n > BUFSIZ) { - fread(buffer, BUFSIZ, 1, from); - fwrite(buffer, BUFSIZ, 1, to); - n -= BUFSIZ; - } else if (n > 0) { - fread(buffer, 1, n, from); - fwrite(buffer, 1, n, to); - break; - } else - break; -} -/* **************************************************************** - * unexec - * - * driving logic. - * ****************************************************************/ -unexec (new_name, a_name, data_start, bss_start, entry_address) -char *new_name, *a_name; -unsigned data_start, bss_start, entry_address; -{ - struct coffheader header1; - struct coffscn *tp, *dp, *bp; - struct exec header; - int stsize; - char *original_file = a_name; - char *save_file = new_name; - - char *data_begin, *data_end; - int original_data; - FILE *original, *save; - register int n; - register char *p; - extern char *sbrk(); - char stdin_buf[BUFSIZ], stdout_buf[BUFSIZ]; - - - fclose(stdin); - original = fopen(original_file, "r"); - if (stdin != original || original->_file != 0) { - fprintf(stderr, "unexec: Can't open the original file.\n"); - exit(1); - } - setbuf(original, stdin_buf); - fclose(stdout); - unlink(save_file); - n = open(save_file, O_CREAT|O_WRONLY, 0777); - if (n != 1 || (save = fdopen(n, "w")) != stdout) { - fprintf(stderr, "unexec: Can't open the save file.\n"); - exit(1); - } - setbuf(save, stdout_buf); - - fread(&header1, sizeof(header1), 1, original); - tp = &header1.scns[0]; - dp = &header1.scns[1]; - bp = &header1.scns[2]; - fread(&header, sizeof(header), 1, original); - data_begin=(char *)N_DATADDR(header); - data_end = sbrk(0); - original_data = header.a_data; - header.a_data = data_end - data_begin; - header.a_bss = 0; - dp->s_size = header.a_data; - bp->s_paddr = dp->s_vaddr + dp->s_size; - bp->s_vaddr = bp->s_paddr; - bp->s_size = 0; - header1.tsize = tp->s_size; - header1.dsize = dp->s_size; - header1.bsize = bp->s_size; - fwrite(&header1, sizeof(header1), 1, save); - fwrite(&header, sizeof(header), 1, save); - - filecpy(save, original, header.a_text); - - for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) - if (n > BUFSIZ) - fwrite(p, BUFSIZ, 1, save); - else if (n > 0) { - fwrite(p, 1, n, save); - break; - } else - break; - - fseek(original, original_data, 1); - - filecpy(save, original, header.a_syms+header.a_trsize+header.a_drsize); - fread(&stsize, sizeof(stsize), 1, original); - fwrite(&stsize, sizeof(stsize), 1, save); - filecpy(save, original, stsize - sizeof(stsize)); - - fclose(original); - fclose(save); -}
--- a/src/unexfx2800.c Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,16 +0,0 @@ -/* Unexec for the Alliant FX/2800. */ - -#include <stdio.h> - -unexec (new_name, a_name, data_start, bss_start, entry_address) - char *new_name, *a_name; - unsigned data_start, bss_start, entry_address; -{ - int stat; - - stat = elf_write_modified_data (a_name, new_name); - if (stat < 0) - perror ("emacs: elf_write_modified_data"); - else if (stat > 0) - fprintf (stderr, "Unspecified error from elf_write_modified_data.\n"); -}
--- a/src/vms-pp.c Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,243 +0,0 @@ -/* vms_pp - preprocess emacs files in such a way that they can be - * compiled on VMS without warnings. - * Copyright (C) 1986 Free Software Foundation, Inc. - - This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. - - * - * Usage: - * vms_pp infile outfile - * implicit inputs: - * The file "vms_pp.trans" has the names and their translations. - * description: - * Vms_pp takes the input file and scans it, replacing the long - * names with shorter names according to the table read in from - * vms_pp.trans. The line is then written to the output file. - * - * Additionally, the "#undef foo" construct is replaced with: - * #ifdef foo - * #undef foo - * #endif - * - * The construct #if defined(foo) is replaced with - * #ifdef foo - * #define foo_VAL 1 - * #else - * #define foo_VAL 0 - * #endif - * #define defined(XX) XX_val - * #if defined(foo) - * - * This last construction only works on single line #if's and takes - * advantage of a questionable C pre-processor trick. If there are - * comments within the #if, that contain "defined", then this will - * bomb. - */ -#include <stdio.h> - -#define Max_table 100 -#define Table_name "vms_pp.trans" -#define Word_member \ -"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$" - -static FILE *in,*out; /* read from, write to */ -struct item { /* symbol table entries */ - char *name; - char *value; -}; -static struct item name_table[Max_table]; /* symbol table */ -static int defined_defined = 0; /* small optimization */ - -main(argc,argv) int argc; char **argv; { - char buffer[1024]; - - if(argc != 3) { /* check argument count */ - fprintf(stderr,"usage: vms_pp infile outfile"); - exit(); - } - init_table(); /* read in translation table */ - -/* open input and output files - */ - if((in = fopen(argv[1],"r")) == NULL) { - fprintf(stderr,"vms_pp: unable to open file '%s'",argv[1]); - exit(); - } - if((out = fopen(argv[2],"w")) == NULL) { - fprintf(stderr,"vms_pp: unable to create file '%s'",argv[2]); - exit(); - } - - while(fgets(buffer,1023,in) != NULL) { /* loop through buffer until end */ - process_line(buffer); /* process the line */ - fputs(buffer,out); /* write out the line */ - } -} - -/* buy - allocate and copy a string - */ -static char *buy(str) char *str; { - char *temp; - - if(!(temp = malloc(strlen(str)+1))) { - fprintf(stderr,"vms_pp: can't allocate memory"); - exit(); - } - strcpy(temp,str); - return temp; -} - -/* gather_word - return a buffer full of the next word - */ -static char *gather_word(ptr,word) char *ptr, *word;{ - for(; strchr(Word_member,*ptr); ptr++,word++) - *word = *ptr; - *word = 0; - return ptr; -} - -/* skip_white - skip white space - */ -static char *skip_white(ptr) char *ptr; { - while(*ptr == ' ' || *ptr == '\t') - ptr++; - return ptr; -} - -/* init_table - initialize translation table. - */ -init_table() { - char buf[256],*ptr,word[128]; - FILE *in; - int i; - - if((in = fopen(Table_name,"r")) == NULL) { /* open file */ - fprintf(stderr,"vms_pp: can't open '%s'",Table_name); - exit(); - } - for(i = 0; fgets(buf,255,in) != NULL;) { /* loop through lines */ - ptr = skip_white(buf); - if(*ptr == '!') /* skip comments */ - continue; - ptr = gather_word(ptr,word); /* get long word */ - if(*word == 0) { /* bad entry */ - fprintf(stderr,"vms_pp: bad input line '%s'\n",buf); - continue; - } - name_table[i].name = buy(word); /* set up the name */ - ptr = skip_white(ptr); /* skip white space */ - ptr = gather_word(ptr,word); /* get equivalent name */ - if(*word == 0) { /* bad entry */ - fprintf(stderr,"vms_pp: bad input line '%s'\n",buf); - continue; - } - name_table[i].value = buy(word); /* and the equivalent name */ - i++; /* increment to next position */ - } - for(; i < Max_table; i++) /* mark rest as unused */ - name_table[i].name = 0; -} - -/* process_line - do actual line processing - */ -process_line(buf) char *buf; { - char *in_ptr,*out_ptr; - char word[128],*ptr; - int len; - - check_pp(buf); /* check for preprocessor lines */ - - for(in_ptr = out_ptr = buf; *in_ptr;) { - if(!strchr(Word_member,*in_ptr)) /* non alpha-numeric? just copy */ - *out_ptr++ = *in_ptr++; - else { - in_ptr = gather_word(in_ptr,word); /* get the 'word' */ - if(strlen(word) > 31) /* length is too long */ - replace_word(word); /* replace the word */ - for(ptr = word; *ptr; ptr++,out_ptr++) /* copy out the word */ - *out_ptr = *ptr; - } - } - *out_ptr = 0; -} - -/* check_pp - check for preprocessor lines - */ -check_pp(buf) char *buf; { - char *ptr,*p; - char word[128]; - - ptr = skip_white(buf); /* skip white space */ - if(*ptr != '#') /* is this a preprocessor line? */ - return; /* no, just return */ - - ptr = skip_white(++ptr); /* skip white */ - ptr = gather_word(ptr,word); /* get command word */ - if(!strcmp("undef",word)) { /* undef? */ - ptr = skip_white(ptr); - ptr = gather_word(ptr,word); /* get the symbol to undef */ - fprintf(out,"#ifdef %s\n",word); - fputs(buf,out); - strcpy(buf,"#endif"); - return; - } - if(!strcmp("if",word)) { /* check for if */ - for(;;) { - ptr = strchr(ptr,'d'); /* look for d in defined */ - if(!ptr) /* are we done? */ - return; - if(strchr(Word_member,*(ptr-1))){ /* at beginning of word? */ - ptr++; continue; /* no, continue looking */ - } - ptr = gather_word(ptr,word); /* get the word */ - if(strcmp(word,"defined")) /* skip if not defined */ - continue; - ptr = skip_white(ptr); /* skip white */ - if(*ptr != '(') /* look for open paren */ - continue; /* error, continue */ - ptr++; /* skip paren */ - ptr = skip_white(ptr); /* more white skipping */ - ptr = gather_word(ptr,word); /* get the thing to test */ - if(!*word) /* null word is bad */ - continue; - fprintf(out,"#ifdef %s\n",word); /* generate the code */ - fprintf(out,"#define %s_VAL 1\n",word); - fprintf(out,"#else\n"); - fprintf(out,"#define %s_VAL 0\n",word); - fprintf(out,"#endif\n"); - if(!defined_defined) { - fprintf(out,"#define defined(XXX) XXX/**/_VAL\n"); - defined_defined = 1; - } - } - } -} - -/* replace_word - look the word up in the table, and replace it - * if a match is found. - */ -replace_word(word) char *word; { - int i; - - for(i = 0; i < Max_table && name_table[i].name; i++) - if(!strcmp(word,name_table[i].name)) { - strcpy(word,name_table[i].value); - return; - } - fprintf(stderr,"couldn't find '%s'\n",word); -}
--- a/src/vms-pp.trans Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -! translations for extra long variable names -!234567890123456789012345678901 1234567890123456789012345678901 -Vminibuffer_local_completion_map Vminibuf_local_completion_map -Vminibuffer_local_must_match_map Vminibuf_local_must_match -Finsert_abbrev_table_description Finsert_abbrev_table_descrip -Sinsert_abbrev_table_description Sinsert_abbrev_table_descrip -internal_with_output_to_temp_buffer internal_with_out_to_temp_buf -Vminibuffer_completion_predicate Vminibuf_completion_predicate -Qminibuffer_completion_predicate Qminibuf_completion_predicate -
--- a/src/vms-pwd.h Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,35 +0,0 @@ -/* GNU Emacs password definition file. - Copyright (C) 1986 Free Software Foundation. - -This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#ifdef VMS -/* On VMS, we read the UAF file and emulate some of the necessary - fields for Emacs. */ -#include "uaf.h" - -struct passwd { - char pw_name[UAF$S_USERNAME+1]; - char pw_passwd[UAF$S_PWD]; - short pw_uid; - short pw_gid; - char pw_gecos[UAF$S_OWNER+1]; - char pw_dir[UAF$S_DEFDEV+UAF$S_DEFDIR+1]; - char pw_shell[UAF$S_DEFCLI+1]; -}; -#endif /* VMS */
--- a/src/vmsdir.h Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,98 +0,0 @@ -/* GNU Emacs VMS directory definition file. - Copyright (C) 1986 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -/* - * Files-11 Ver. 2 directory structure (VMS V4.x - long names) - */ -#ifndef DIR$K_LENGTH - -#define DIR$C_FID 0 -#define DIR$C_LINKNAME 1 -#define DIR$K_LENGTH 6 -#define DIR$C_LENGTH 6 -#define DIR$S_DIRDEF 6 -#define DIR$W_SIZE 0 -#define DIR$W_VERLIMIT 2 -#define DIR$B_FLAGS 4 -#define DIR$S_TYPE 3 -#define DIR$V_TYPE 0 -#define DIR$V_NEXTREC 6 -#define DIR$V_PREVREC 7 -#define DIR$B_NAMECOUNT 5 -#define DIR$S_NAME 80 -#define DIR$T_NAME 6 - -#define DIR$K_VERSION 8 -#define DIR$C_VERSION 8 -#define DIR$S_DIRDEF1 8 -#define DIR$W_VERSION 0 -#define DIR$S_FID 6 -#define DIR$W_FID 2 -#define DIR$W_FID_NUM 2 -#define DIR$W_FID_SEQ 4 -#define DIR$W_FID_RVN 6 -#define DIR$B_FID_RVN 6 -#define DIR$B_FID_NMX 7 - -#define DIR$S_DIRDEF2 1 -#define DIR$T_LINKNAME 0 - -typedef struct dir$_name { -/* short dir$w_size; /* if you read with RMS, it eats this... */ - short dir$w_verlimit; /* maximum number of versions */ - union { - unsigned char dir_b_flags; -#define dir$b_flags dir__b_flags.dir_b_flags - struct { - unsigned char dir_v_type: DIR$S_TYPE; -#define dir$v_type dir__b_flags.dir___b_flags.dir_v_type - unsigned char: 3; - unsigned char dir_v_nextrec: 1; -#define dir$v_nextrec dir__b_flags.dir___b_flags.dir_v_nextrec - unsigned char dir_v_prevrec: 1; -#define dir$v_prevrec dir__b_flags.dir___b_flags.dir_v_prevrec - } dir___b_flags; - } dir__b_flags; - unsigned char dir$b_namecount; - char dir$t_name[]; -} dir$_dirdef; /* only the fixed first part */ - -typedef struct dir$_version { - short dir$w_version; - short dir$w_fid_num; - short dir$w_fid_seq; - union { - short dir_w_fid_rvn; -#define dir$w_fid_rvn dir__w_fid_rvn.dir_w_fid_rvn - struct { - char dir_b_fid_rvn; -#define dir$b_fid_rvn dir__w_fid_rvn.dir___w_fid_rvn.dir_b_fid_rvn - char dir_b_fid_nmx; -#define dir$b_fid_nmx dir__w_fid_rvn.dir___w_fid_rvn.dir_b_fid_nmx - } dir___w_fid_rvn; - } dir__w_fid_rvn; -} dir$_dirdef1; /* one for each version of the file */ - -typedef -struct dir$_linkname { - char dir$t_linkname[]; -} dir$_dirdef2; - -#endif
--- a/src/vmsfns.c Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,962 +0,0 @@ -/* VMS subprocess and command interface. - Copyright (C) 1987, 1988, 1999 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -/* Written by Mukesh Prasad. */ - -/* - * INTERFACE PROVIDED BY EMACS FOR VMS SUBPROCESSES: - * - * Emacs provides the following functions: - * - * "spawn-subprocess", which takes as arguments: - * - * (i) an integer to identify the spawned subprocess in future - * operations, - * (ii) A function to process input from the subprocess, and - * (iii) A function to be called upon subprocess termination. - * - * First argument is required. If second argument is missing or nil, - * the default action is to insert all received messages at the current - * location in the current buffer. If third argument is missing or nil, - * no action is taken upon subprocess termination. - * The input-handler is called as - * (input-handler num string) - * where num is the identifying integer for the subprocess and string - * is a string received from the subprocess. exit-handler is called - * with the identifying integer as the argument. - * - * "send-command-to-subprocess" takes two arguments: - * - * (i) Subprocess identifying integer. - * (ii) String to send as a message to the subprocess. - * - * "stop-subprocess" takes the subprocess identifying integer as - * argument. - * - * Implementation is done by spawning an asynchronous subprocess, and - * communicating to it via mailboxes. - */ - -#ifdef VMS - -#include <config.h> -#include <stdio.h> -#include <ctype.h> -#undef NULL - -#include "lisp.h" -#include <descrip.h> -#include <dvidef.h> -#include <prvdef.h> -/* #include <clidef.h> */ -#include <iodef.h> -#include <ssdef.h> -#include <errno.h> - -#ifdef VMS4_4 /* I am being cautious; perhaps this exists in older versions */ -#include <jpidef.h> -#endif - -/* #include <syidef.h> */ - -#define CLI$M_NOWAIT 1 /* clidef.h is missing from C library */ -#define SYI$_VERSION 4096 /* syidef.h is missing from C library */ -#define JPI$_CLINAME 522 /* JPI$_CLINAME is missing from jpidef.h */ -#define JPI$_MASTER_PID 805 /* JPI$_MASTER_PID missing from jpidef.h */ -#define LIB$_NOSUCHSYM 1409892 /* libclidef.h missing */ - -#define MSGSIZE 160 /* Maximum size for mailbox operations */ - -#ifndef PRV$V_ACNT - -/* these defines added as hack for VMS 5.1-1. SJones, 8-17-89 */ -/* this is _really_ nasty and needs to be changed ASAP - should see about - using the union defined in SYS$LIBRARY:PRVDEF.H under v5 */ - -#define PRV$V_ACNT 0x09 -#define PRV$V_ALLSPOOL 0x04 -#define PRV$V_ALTPRI 0x0D -#define PRV$V_BUGCHK 0x17 -#define PRV$V_BYPASS 0x1D -#define PRV$V_CMEXEC 0x01 -#define PRV$V_CMKRNL 0x00 -#define PRV$V_DETACH 0x05 -#define PRV$V_DIAGNOSE 0x06 -#define PRV$V_DOWNGRADE 0x21 -#define PRV$V_EXQUOTA 0x13 -#define PRV$V_GROUP 0x08 -#define PRV$V_GRPNAM 0x03 -#define PRV$V_GRPPRV 0x22 -#define PRV$V_LOG_IO 0x07 -#define PRV$V_MOUNT 0x11 -#define PRV$V_NETMBX 0x14 -#define PRV$V_NOACNT 0x09 -#define PRV$V_OPER 0x12 -#define PRV$V_PFNMAP 0x1A -#define PRV$V_PHY_IO 0x16 -#define PRV$V_PRMCEB 0x0A -#define PRV$V_PRMGBL 0x18 -#define PRV$V_PRMJNL 0x25 -#define PRV$V_PRMMBX 0x0B -#define PRV$V_PSWAPM 0x0C -#define PRV$V_READALL 0x23 -#define PRV$V_SECURITY 0x26 -#define PRV$V_SETPRI 0x0D -#define PRV$V_SETPRV 0x0E -#define PRV$V_SHARE 0x1F -#define PRV$V_SHMEM 0x1B -#define PRV$V_SYSGBL 0x19 -#define PRV$V_SYSLCK 0x1E -#define PRV$V_SYSNAM 0x02 -#define PRV$V_SYSPRV 0x1C -#define PRV$V_TMPJNL 0x24 -#define PRV$V_TMPMBX 0x0F -#define PRV$V_UPGRADE 0x20 -#define PRV$V_VOLPRO 0x15 -#define PRV$V_WORLD 0x10 -#endif - -/* IO status block for mailbox operations. */ -struct mbx_iosb -{ - short status; - short size; - int pid; -}; - -/* Structure for maintaining linked list of subprocesses. */ -struct process_list -{ - int name; /* Numeric identifier for subprocess */ - int process_id; /* VMS process address */ - int process_active; /* 1 iff process has not exited yet */ - int mbx_chan; /* Mailbox channel to write to process */ - struct mbx_iosb iosb; /* IO status block for write operations */ - Lisp_Object input_handler; /* Input handler for subprocess */ - Lisp_Object exit_handler; /* Exit handler for subprocess */ - struct process_list * next; /* Linked list chain */ -}; - -/* Structure for privilege list. */ -struct privilege_list -{ - char * name; - int mask; -}; - -/* Structure for finding VMS related information. */ -struct vms_objlist -{ - char * name; /* Name of object */ - Lisp_Object (* objfn)(); /* Function to retrieve VMS object */ -}; - -static int exit_ast (); /* Called upon subprocess exit */ -static int create_mbx (); /* Creates mailbox */ -static void mbx_msg (); /* Writes null terminated string to mbx */ -static void write_to_mbx (); /* Writes message to string */ -static void start_mbx_input (); /* Queues I/O request to mailbox */ - -static int input_mbx_chan = 0; /* Channel to read subprocess input on */ -static char input_mbx_name[20]; - /* Storage for mailbox device name */ -static struct dsc$descriptor_s input_mbx_dsc; - /* Descriptor for mailbox device name */ -static struct process_list * process_list = 0; - /* Linked list of subprocesses */ -static char mbx_buffer[MSGSIZE]; - /* Buffer to read from subprocesses */ -static struct mbx_iosb input_iosb; - /* IO status block for mailbox reads */ - -int have_process_input, /* Non-zero iff subprocess input pending */ - process_exited; /* Non-zero iff suprocess exit pending */ - -/* List of privilege names and mask offsets */ -static struct privilege_list priv_list[] = { - - { "ACNT", PRV$V_ACNT }, - { "ALLSPOOL", PRV$V_ALLSPOOL }, - { "ALTPRI", PRV$V_ALTPRI }, - { "BUGCHK", PRV$V_BUGCHK }, - { "BYPASS", PRV$V_BYPASS }, - { "CMEXEC", PRV$V_CMEXEC }, - { "CMKRNL", PRV$V_CMKRNL }, - { "DETACH", PRV$V_DETACH }, - { "DIAGNOSE", PRV$V_DIAGNOSE }, - { "DOWNGRADE", PRV$V_DOWNGRADE }, /* Isn't VMS as low as you can go? */ - { "EXQUOTA", PRV$V_EXQUOTA }, - { "GRPPRV", PRV$V_GRPPRV }, - { "GROUP", PRV$V_GROUP }, - { "GRPNAM", PRV$V_GRPNAM }, - { "LOG_IO", PRV$V_LOG_IO }, - { "MOUNT", PRV$V_MOUNT }, - { "NETMBX", PRV$V_NETMBX }, - { "NOACNT", PRV$V_NOACNT }, - { "OPER", PRV$V_OPER }, - { "PFNMAP", PRV$V_PFNMAP }, - { "PHY_IO", PRV$V_PHY_IO }, - { "PRMCEB", PRV$V_PRMCEB }, - { "PRMGBL", PRV$V_PRMGBL }, - { "PRMJNL", PRV$V_PRMJNL }, - { "PRMMBX", PRV$V_PRMMBX }, - { "PSWAPM", PRV$V_PSWAPM }, - { "READALL", PRV$V_READALL }, - { "SECURITY", PRV$V_SECURITY }, - { "SETPRI", PRV$V_SETPRI }, - { "SETPRV", PRV$V_SETPRV }, - { "SHARE", PRV$V_SHARE }, - { "SHMEM", PRV$V_SHMEM }, - { "SYSGBL", PRV$V_SYSGBL }, - { "SYSLCK", PRV$V_SYSLCK }, - { "SYSNAM", PRV$V_SYSNAM }, - { "SYSPRV", PRV$V_SYSPRV }, - { "TMPJNL", PRV$V_TMPJNL }, - { "TMPMBX", PRV$V_TMPMBX }, - { "UPGRADE", PRV$V_UPGRADE }, - { "VOLPRO", PRV$V_VOLPRO }, - { "WORLD", PRV$V_WORLD }, - - }; - -static Lisp_Object - vms_account(), vms_cliname(), vms_owner(), vms_grp(), vms_image(), - vms_parent(), vms_pid(), vms_prcnam(), vms_terminal(), vms_uic_int(), - vms_uic_str(), vms_username(), vms_version_fn(), vms_trnlog(), - vms_symbol(), vms_proclist(); - -/* Table of arguments to Fvms_object, and the handlers that get the data. */ - -static struct vms_objlist vms_object [] = { - { "ACCOUNT", vms_account }, /* Returns account name as a string */ - { "CLINAME", vms_cliname }, /* Returns CLI name (string) */ - { "OWNER", vms_owner }, /* Returns owner process's PID (int) */ - { "GRP", vms_grp }, /* Returns group number of UIC (int) */ - { "IMAGE", vms_image }, /* Returns executing image (string) */ - { "PARENT", vms_parent }, /* Returns parent proc's PID (int) */ - { "PID", vms_pid }, /* Returns process's PID (int) */ - { "PRCNAM", vms_prcnam }, /* Returns process's name (string) */ - { "TERMINAL", vms_terminal }, /* Returns terminal name (string) */ - { "UIC", vms_uic_int }, /* Returns UIC as integer */ - { "UICGRP", vms_uic_str }, /* Returns UIC as string */ - { "USERNAME", vms_username }, /* Returns username (string) */ - { "VERSION", vms_version_fn },/* Returns VMS version (string) */ - { "LOGICAL", vms_trnlog }, /* Translates VMS logical name */ - { "DCL-SYMBOL", vms_symbol }, /* Translates DCL symbol */ - { "PROCLIST", vms_proclist }, /* Returns list of all PIDs on system */ - }; - -Lisp_Object Qdefault_subproc_input_handler; - -extern int process_ef; /* Event flag for subprocess operations */ - -DEFUN ("default-subprocess-input-handler", - Fdefault_subproc_input_handler, Sdefault_subproc_input_handler, - 2, 2, 0, - "Default input handler for input from spawned subprocesses.") - (name, input) - Lisp_Object name, input; -{ - /* Just insert in current buffer */ - insert1 (input); - insert ("\n", 1); -} - -DEFUN ("spawn-subprocess", Fspawn_subprocess, Sspawn_subprocess, 1, 3, 0, - "Spawn an asynchronous VMS suprocess for command processing.") - (name, input_handler, exit_handler) - Lisp_Object name, input_handler, exit_handler; -{ - int status; - char output_mbx_name[20]; - struct dsc$descriptor_s output_mbx_dsc; - struct process_list *ptr, *p, *prev; - - CHECK_NUMBER (name, 0); - if (! input_mbx_chan) - { - if (! create_mbx (&input_mbx_dsc, input_mbx_name, &input_mbx_chan, 1)) - return Qnil; - start_mbx_input (); - } - ptr = 0; - prev = 0; - while (ptr) - { - struct process_list *next = ptr->next; - if (ptr->name == XFASTINT (name)) - { - if (ptr->process_active) - return Qt; - - /* Delete this process and run its exit handler. */ - if (prev) - prev->next = next; - else - process_list = next; - if (! NILP (ptr->exit_handler)) - Feval (Fcons (ptr->exit_handler, Fcons (make_number (ptr->name), - Qnil))); - sys$dassgn (ptr->mbx_chan); - break; - } - else - prev = ptr; - ptr = next; - } - if (! ptr) - ptr = xmalloc (sizeof (struct process_list)); - if (! create_mbx (&output_mbx_dsc, output_mbx_name, &ptr->mbx_chan, 2)) - { - free (ptr); - return Qnil; - } - if (NILP (input_handler)) - input_handler = Qdefault_subproc_input_handler; - ptr->input_handler = input_handler; - ptr->exit_handler = exit_handler; - message ("Creating subprocess..."); - status = lib$spawn (0, &output_mbx_dsc, &input_mbx_dsc, &CLI$M_NOWAIT, 0, - &ptr->process_id, 0, 0, exit_ast, &ptr->process_active); - if (! (status & 1)) - { - sys$dassgn (ptr->mbx_chan); - free (ptr); - error ("Unable to spawn subprocess"); - return Qnil; - } - ptr->name = XFASTINT (name); - ptr->next = process_list; - ptr->process_active = 1; - process_list = ptr; - message ("Creating subprocess...done"); - return Qt; -} - -static void -mbx_msg (ptr, msg) - struct process_list *ptr; - char *msg; -{ - write_to_mbx (ptr, msg, strlen (msg)); -} - -DEFUN ("send-command-to-subprocess", - Fsend_command_to_subprocess, Ssend_command_to_subprocess, 2, 2, - "sSend command to subprocess: \nsSend subprocess %s command: ", - "Send to VMS subprocess named NAME the string COMMAND.") - (name, command) - Lisp_Object name, command; -{ - struct process_list * ptr; - - CHECK_NUMBER (name, 0); - CHECK_STRING (command, 1); - for (ptr = process_list; ptr; ptr = ptr->next) - if (XFASTINT (name) == ptr->name) - { - write_to_mbx (ptr, XSTRING (command)->data, - XSTRING (command)->size); - return Qt; - } - return Qnil; -} - -DEFUN ("stop-subprocess", Fstop_subprocess, Sstop_subprocess, 1, 1, - "sStop subprocess: ", "Stop VMS subprocess named NAME.") - (name) - Lisp_Object name; -{ - struct process_list * ptr; - - CHECK_NUMBER (name, 0); - for (ptr = process_list; ptr; ptr = ptr->next) - if (XFASTINT (name) == ptr->name) - { - ptr->exit_handler = Qnil; - if (sys$delprc (&ptr->process_id, 0) & 1) - ptr->process_active = 0; - return Qt; - } - return Qnil; -} - -static int -exit_ast (active) - int * active; -{ - process_exited = 1; - *active = 0; - sys$setef (process_ef); -} - -/* Process to handle input on the input mailbox. - * Searches through the list of processes until the matching PID is found, - * then calls its input handler. - */ - -process_command_input () -{ - struct process_list * ptr; - char * msg; - int msglen; - Lisp_Object expr; - - msg = mbx_buffer; - msglen = input_iosb.size; - /* Hack around VMS oddity of sending extraneous CR/LF characters for - * some of the commands (but not most). - */ - if (msglen > 0 && *msg == '\r') - { - msg++; - msglen--; - } - if (msglen > 0 && msg[msglen - 1] == '\n') - msglen--; - if (msglen > 0 && msg[msglen - 1] == '\r') - msglen--; - /* Search for the subprocess in the linked list. - */ - expr = Qnil; - for (ptr = process_list; ptr; ptr = ptr->next) - if (ptr->process_id == input_iosb.pid) - { - expr = Fcons (ptr->input_handler, - Fcons (make_number (ptr->name), - Fcons (make_string (msg, msglen), - Qnil))); - break; - } - have_process_input = 0; - start_mbx_input (); - clear_waiting_for_input (); /* Otherwise Ctl-g will cause crash. JCB */ - if (! NILP (expr)) - Feval (expr); -} - -/* Searches process list for any processes which have exited. Calls their - * exit handlers and removes them from the process list. - */ - -process_exit () -{ - struct process_list * ptr, * prev, * next; - - process_exited = 0; - prev = 0; - ptr = process_list; - while (ptr) - { - next = ptr->next; - if (! ptr->process_active) - { - if (prev) - prev->next = next; - else - process_list = next; - if (! NILP (ptr->exit_handler)) - Feval (Fcons (ptr->exit_handler, Fcons (make_number (ptr->name), - Qnil))); - sys$dassgn (ptr->mbx_chan); - free (ptr); - } - else - prev = ptr; - ptr = next; - } -} - -/* Called at emacs exit. - */ - -kill_vms_processes () -{ - struct process_list * ptr; - - for (ptr = process_list; ptr; ptr = ptr->next) - if (ptr->process_active) - { - sys$dassgn (ptr->mbx_chan); - sys$delprc (&ptr->process_id, 0); - } - sys$dassgn (input_mbx_chan); - process_list = 0; - input_mbx_chan = 0; -} - -/* Creates a temporary mailbox and retrieves its device name in 'buf'. - * Makes the descriptor pointed to by 'dsc' refer to this device. - * 'buffer_factor' is used to allow sending messages asynchronously - * till some point. - */ - -static int -create_mbx (dsc, buf, chan, buffer_factor) - struct dsc$descriptor_s *dsc; - char *buf; - int *chan; - int buffer_factor; -{ - int strval[2]; - int status; - - status = sys$crembx (0, chan, MSGSIZE, MSGSIZE * buffer_factor, 0, 0, 0); - if (! (status & 1)) - { - message ("Unable to create mailbox. Need TMPMBX privilege."); - return 0; - } - strval[0] = 16; - strval[1] = buf; - status = lib$getdvi (&DVI$_DEVNAM, chan, 0, 0, strval, - &dsc->dsc$w_length); - if (! (status & 1)) - return 0; - dsc->dsc$b_dtype = DSC$K_DTYPE_T; - dsc->dsc$b_class = DSC$K_CLASS_S; - dsc->dsc$a_pointer = buf; - return 1; -} /* create_mbx */ - -/* AST routine to be called upon receiving mailbox input. - * Sets flag telling keyboard routines that input is available. - */ - -static int -mbx_input_ast () -{ - have_process_input = 1; -} - -/* Issue a QIO request on the input mailbox. - */ -static void -start_mbx_input () -{ - sys$qio (process_ef, input_mbx_chan, IO$_READVBLK, &input_iosb, - mbx_input_ast, 0, mbx_buffer, sizeof (mbx_buffer), - 0, 0, 0, 0); -} - -/* Send a message to the subprocess input mailbox, without blocking if - * possible. - */ -static void -write_to_mbx (ptr, buf, len) - struct process_list *ptr; - char *buf; - int len; -{ - sys$qiow (0, ptr->mbx_chan, IO$_WRITEVBLK | IO$M_NOW, &ptr->iosb, - 0, 0, buf, len, 0, 0, 0, 0); -} - -DEFUN ("setprv", Fsetprv, Ssetprv, 1, 3, 0, - "Set or reset a VMS privilege. First arg is privilege name.\n\ -Second arg is t or nil, indicating whether the privilege is to be\n\ -set or reset. Default is nil. Returns t if success, nil if not.\n\ -If third arg is non-nil, does not change privilege, but returns t\n\ -or nil depending upon whether the privilege is already enabled.") - (priv, value, getprv) - Lisp_Object priv, value, getprv; -{ - int prvmask[2], prvlen, newmask[2]; - char * prvname; - int found, i; - struct privilege_list * ptr; - - CHECK_STRING (priv, 0); - priv = Fupcase (priv); - prvname = XSTRING (priv)->data; - prvlen = XSTRING (priv)->size; - found = 0; - prvmask[0] = 0; - prvmask[1] = 0; - for (i = 0; i < sizeof (priv_list) / sizeof (priv_list[0]); i++) - { - ptr = &priv_list[i]; - if (prvlen == strlen (ptr->name) && - bcmp (prvname, ptr->name, prvlen) == 0) - { - if (ptr->mask >= 32) - prvmask[1] = 1 << (ptr->mask % 32); - else - prvmask[0] = 1 << ptr->mask; - found = 1; - break; - } - } - if (! found) - error ("Unknown privilege name %s", XSTRING (priv)->data); - if (NILP (getprv)) - { - if (sys$setprv (NILP (value) ? 0 : 1, prvmask, 0, 0) == SS$_NORMAL) - return Qt; - return Qnil; - } - /* Get old priv value */ - if (sys$setprv (0, 0, 0, newmask) != SS$_NORMAL) - return Qnil; - if ((newmask[0] & prvmask[0]) - || (newmask[1] & prvmask[1])) - return Qt; - return Qnil; -} - -/* Retrieves VMS system information. */ - -#ifdef VMS4_4 /* I don't know whether these functions work in old versions */ - -DEFUN ("vms-system-info", Fvms_system_info, Svms_system_info, 1, 3, 0, - "Retrieve VMS process and system information.\n\ -The first argument (a string) specifies the type of information desired.\n\ -The other arguments depend on the type you select.\n\ -For information about a process, the second argument is a process ID\n\ -or a process name, with the current process as a default.\n\ -These are the possibilities for the first arg (upper or lower case ok):\n\ - account Returns account name\n\ - cliname Returns CLI name\n\ - owner Returns owner process's PID\n\ - grp Returns group number\n\ - parent Returns parent process's PID\n\ - pid Returns process's PID\n\ - prcnam Returns process's name\n\ - terminal Returns terminal name\n\ - uic Returns UIC number\n\ - uicgrp Returns formatted [UIC,GRP]\n\ - username Returns username\n\ - version Returns VMS version\n\ - logical Translates VMS logical name (second argument)\n\ - dcl-symbol Translates DCL symbol (second argument)\n\ - proclist Returns list of all PIDs on system (needs WORLD privilege)." ) - (type, arg1, arg2) - Lisp_Object type, arg1, arg2; -{ - int i, typelen; - char * typename; - struct vms_objlist * ptr; - - CHECK_STRING (type, 0); - type = Fupcase (type); - typename = XSTRING (type)->data; - typelen = XSTRING (type)->size; - for (i = 0; i < sizeof (vms_object) / sizeof (vms_object[0]); i++) - { - ptr = &vms_object[i]; - if (typelen == strlen (ptr->name) - && bcmp (typename, ptr->name, typelen) == 0) - return (* ptr->objfn)(arg1, arg2); - } - error ("Unknown object type %s", typename); -} - -/* Given a reference to a VMS process, returns its process id. */ - -static int -translate_id (pid, owner) - Lisp_Object pid; - int owner; /* if pid is null/0, return owner. If this - * flag is 0, return self. */ -{ - int status, code, id, i, numeric, size; - char * p; - int prcnam[2]; - - if (NILP (pid) - || STRINGP (pid) && XSTRING (pid)->size == 0 - || INTEGERP (pid) && XFASTINT (pid) == 0) - { - code = owner ? JPI$_OWNER : JPI$_PID; - status = lib$getjpi (&code, 0, 0, &id); - if (! (status & 1)) - error ("Cannot find %s: %s", - owner ? "owner process" : "process id", - vmserrstr (status)); - return (id); - } - if (INTEGERP (pid)) - return (XFASTINT (pid)); - CHECK_STRING (pid, 0); - pid = Fupcase (pid); - size = XSTRING (pid)->size; - p = XSTRING (pid)->data; - numeric = 1; - id = 0; - for (i = 0; i < size; i++, p++) - if (isxdigit (*p)) - { - id *= 16; - if (*p >= '0' && *p <= '9') - id += *p - '0'; - else - id += *p - 'A' + 10; - } - else - { - numeric = 0; - break; - } - if (numeric) - return (id); - prcnam[0] = XSTRING (pid)->size; - prcnam[1] = XSTRING (pid)->data; - status = lib$getjpi (&JPI$_PID, 0, prcnam, &id); - if (! (status & 1)) - error ("Cannot find process id: %s", - vmserrstr (status)); - return (id); -} /* translate_id */ - -/* VMS object retrieval functions. */ - -static Lisp_Object -getjpi (jpicode, arg, numeric) - int jpicode; /* Type of GETJPI information */ - Lisp_Object arg; - int numeric; /* 1 if numeric value expected */ -{ - int id, status, numval; - char str[128]; - int strdsc[2] = { sizeof (str), str }; - short strlen; - - id = translate_id (arg, 0); - status = lib$getjpi (&jpicode, &id, 0, &numval, strdsc, &strlen); - if (! (status & 1)) - error ("Unable to retrieve information: %s", - vmserrstr (status)); - if (numeric) - return (make_number (numval)); - return (make_string (str, strlen)); -} - -static Lisp_Object -vms_account (arg1, arg2) - Lisp_Object arg1, arg2; -{ - return getjpi (JPI$_ACCOUNT, arg1, 0); -} - -static Lisp_Object -vms_cliname (arg1, arg2) - Lisp_Object arg1, arg2; -{ - return getjpi (JPI$_CLINAME, arg1, 0); -} - -static Lisp_Object -vms_grp (arg1, arg2) - Lisp_Object arg1, arg2; -{ - return getjpi (JPI$_GRP, arg1, 1); -} - -static Lisp_Object -vms_image (arg1, arg2) - Lisp_Object arg1, arg2; -{ - return getjpi (JPI$_IMAGNAME, arg1, 0); -} - -static Lisp_Object -vms_owner (arg1, arg2) - Lisp_Object arg1, arg2; -{ - return getjpi (JPI$_OWNER, arg1, 1); -} - -static Lisp_Object -vms_parent (arg1, arg2) - Lisp_Object arg1, arg2; -{ - return getjpi (JPI$_MASTER_PID, arg1, 1); -} - -static Lisp_Object -vms_pid (arg1, arg2) - Lisp_Object arg1, arg2; -{ - return getjpi (JPI$_PID, arg1, 1); -} - -static Lisp_Object -vms_prcnam (arg1, arg2) - Lisp_Object arg1, arg2; -{ - return getjpi (JPI$_PRCNAM, arg1, 0); -} - -static Lisp_Object -vms_terminal (arg1, arg2) - Lisp_Object arg1, arg2; -{ - return getjpi (JPI$_TERMINAL, arg1, 0); -} - -static Lisp_Object -vms_uic_int (arg1, arg2) - Lisp_Object arg1, arg2; -{ - return getjpi (JPI$_UIC, arg1, 1); -} - -static Lisp_Object -vms_uic_str (arg1, arg2) - Lisp_Object arg1, arg2; -{ - return getjpi (JPI$_UIC, arg1, 0); -} - -static Lisp_Object -vms_username (arg1, arg2) - Lisp_Object arg1, arg2; -{ - return getjpi (JPI$_USERNAME, arg1, 0); -} - -static Lisp_Object -vms_version_fn (arg1, arg2) - Lisp_Object arg1, arg2; -{ - char str[40]; - int status; - int strdsc[2] = { sizeof (str), str }; - short strlen; - - status = lib$getsyi (&SYI$_VERSION, 0, strdsc, &strlen, 0, 0); - if (! (status & 1)) - error ("Unable to obtain version: %s", vmserrstr (status)); - return (make_string (str, strlen)); -} - -static Lisp_Object -vms_trnlog (arg1, arg2) - Lisp_Object arg1, arg2; -{ - char str[256]; /* Max logical translation is 255 bytes. */ - int status, symdsc[2]; - int strdsc[2] = { sizeof (str), str }; - short length, level; - - CHECK_STRING (arg1, 0); - symdsc[0] = XSTRING (arg1)->size; - symdsc[1] = XSTRING (arg1)->data; - status = lib$sys_trnlog (symdsc, &length, strdsc); - if (! (status & 1)) - error ("Unable to translate logical name: %s", vmserrstr (status)); - if (status == SS$_NOTRAN) - return (Qnil); - return (make_string (str, length)); -} - -static Lisp_Object -vms_symbol (arg1, arg2) - Lisp_Object arg1, arg2; -{ - char str[1025]; /* Max symbol translation is 1024 bytes. */ - int status, symdsc[2]; - int strdsc[2] = { sizeof (str), str }; - short length, level; - - CHECK_STRING (arg1, 0); - symdsc[0] = XSTRING (arg1)->size; - symdsc[1] = XSTRING (arg1)->data; - status = lib$get_symbol (symdsc, strdsc, &length, &level); - if (! (status & 1)) { - if (status == LIB$_NOSUCHSYM) - return (Qnil); - else - error ("Unable to translate symbol: %s", vmserrstr (status)); - } - return (make_string (str, length)); -} - -static Lisp_Object -vms_proclist (arg1, arg2) - Lisp_Object arg1, arg2; -{ - Lisp_Object retval; - int id, status, pid; - - retval = Qnil; - pid = -1; - for (;;) - { - status = lib$getjpi (&JPI$_PID, &pid, 0, &id); - if (status == SS$_NOMOREPROC) - break; - if (! (status & 1)) - error ("Unable to get process ID: %s", vmserrstr (status)); - retval = Fcons (make_number (id), retval); - } - return (Fsort (retval, intern ("<"))); -} - -DEFUN ("shrink-to-icon", Fshrink_to_icon, Sshrink_to_icon, 0, 0, 0, - "If emacs is running in a workstation window, shrink to an icon.") - () -{ - static char result[128]; - static $DESCRIPTOR (result_descriptor, result); - static $DESCRIPTOR (tt_name, "TT:"); - static int chan = 0; - static int buf = 0x9d + ('2'<<8) + ('2'<<16) + (0x9c<<24); - int status; - static int temp = JPI$_TERMINAL; - - status = lib$getjpi (&temp, 0, 0, 0, &result_descriptor, 0); - if (status != SS$_NORMAL) - error ("Unable to determine terminal type."); - if (result[0] != 'W' || result[1] != 'T') /* see if workstation */ - error ("Can't shrink-to-icon on a non workstation terminal"); - if (!chan) /* assign channel if not assigned */ - if ((status = sys$assign (&tt_name, &chan, 0, 0)) != SS$_NORMAL) - error ("Can't assign terminal, %d", status); - status = sys$qiow (0, chan, IO$_WRITEVBLK+IO$M_BREAKTHRU, 0, 0, 0, - &buf, 4, 0, 0, 0, 0); - if (status != SS$_NORMAL) - error ("Can't shrink-to-icon, %d", status); -} - -#endif /* VMS4_4 */ - -init_vmsfns () -{ - process_list = 0; - input_mbx_chan = 0; -} - -syms_of_vmsfns () -{ - defsubr (&Sdefault_subproc_input_handler); - defsubr (&Sspawn_subprocess); - defsubr (&Ssend_command_to_subprocess); - defsubr (&Sstop_subprocess); - defsubr (&Ssetprv); -#ifdef VMS4_4 - defsubr (&Svms_system_info); - defsubr (&Sshrink_to_icon); -#endif /* VMS4_4 */ - Qdefault_subproc_input_handler = intern ("default-subprocess-input-handler"); - staticpro (&Qdefault_subproc_input_handler); -} -#endif /* VMS */ -
--- a/src/vmsgmalloc.c Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2012 +0,0 @@ -/* DO NOT EDIT THIS FILE -- it is automagically generated. -*- C -*- */ - -#define _MALLOC_INTERNAL - -/* The malloc headers and source files from the C library follow here. */ - -/* Declarations for `malloc' and friends. - Copyright 1990, 1991, 1992, 1993, 1999 Free Software Foundation, Inc. - Written May 1989 by Mike Haertel. - -This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. - - The author may be reached (Email) at the address mike@ai.mit.edu, - or (US mail) as Mike Haertel c/o Free Software Foundation. */ - -#ifndef _MALLOC_H - -#define _MALLOC_H 1 - -#ifdef __cplusplus -extern "C" -{ -#endif - -#if defined (__cplusplus) || (defined (__STDC__) && __STDC__) -#undef __P -#define __P(args) args -#undef __const -#define __const const -#undef __ptr_t -#define __ptr_t void * -#else /* Not C++ or ANSI C. */ -#undef __P -#define __P(args) () -#undef __const -#define __const -#undef __ptr_t -#define __ptr_t char * -#endif /* C++ or ANSI C. */ - -#ifndef NULL -#define NULL 0 -#endif - -#if defined (HAVE_CONFIG_H) || defined (emacs) -#include <config.h> -#endif - -#ifdef __STDC__ -#include <stddef.h> -#else -#ifdef VMS /* The following are defined in stdio.h, but we need it NOW! - But do NOT do it with defines here, for then, VAX C is going - to barf when it gets to stdio.h and the typedefs in there! */ -typedef unsigned int size_t; -typedef int ptrdiff_t; -#else /* not VMS */ -#undef size_t -#define size_t unsigned int -#undef ptrdiff_t -#define ptrdiff_t int -#endif /* VMS */ -#endif - - -/* Allocate SIZE bytes of memory. */ -extern __ptr_t malloc __P ((size_t __size)); -/* Re-allocate the previously allocated block - in __ptr_t, making the new block SIZE bytes long. */ -extern __ptr_t realloc __P ((__ptr_t __ptr, size_t __size)); -/* Allocate NMEMB elements of SIZE bytes each, all initialized to 0. */ -extern __ptr_t calloc __P ((size_t __nmemb, size_t __size)); -/* Free a block allocated by `malloc', `realloc' or `calloc'. */ -extern void free __P ((__ptr_t __ptr)); - -/* Allocate SIZE bytes allocated to ALIGNMENT bytes. */ -extern __ptr_t memalign __P ((size_t __alignment, size_t __size)); - -/* Allocate SIZE bytes on a page boundary. */ -extern __ptr_t valloc __P ((size_t __size)); - -#ifdef VMS -/* VMS hooks to deal with two heaps */ -/* Allocate SIZE bytes of memory. */ -extern __ptr_t __vms_malloc __P ((size_t __size)); -/* Re-allocate the previously allocated block - in __ptr_t, making the new block SIZE bytes long. */ -extern __ptr_t __vms_realloc __P ((__ptr_t __ptr, size_t __size)); -/* Free a block allocated by `malloc', `realloc' or `calloc'. */ -extern void __vms_free __P ((__ptr_t __ptr)); -#endif - -#ifdef _MALLOC_INTERNAL - -#include <stdio.h> /* Harmless, gets __GNU_LIBRARY__ defined. */ - -#if defined(__GNU_LIBRARY__) || defined(STDC_HEADERS) || defined(USG) -#include <string.h> -#else -#ifndef memset -#define memset(s, zero, n) bzero ((s), (n)) -#endif -#ifndef memcpy -#define memcpy(d, s, n) bcopy ((s), (d), (n)) -#endif -#ifndef memmove -#define memmove(d, s, n) bcopy ((s), (d), (n)) -#endif -#endif - - -#if defined(__GNU_LIBRARY__) || defined(__STDC__) -#include <limits.h> -#else -#define CHAR_BIT 8 -#endif - -/* The allocator divides the heap into blocks of fixed size; large - requests receive one or more whole blocks, and small requests - receive a fragment of a block. Fragment sizes are powers of two, - and all fragments of a block are the same size. When all the - fragments in a block have been freed, the block itself is freed. */ -#define INT_BIT (CHAR_BIT * sizeof(int)) -#ifdef VMS -#define BLOCKLOG 9 -#else -#define BLOCKLOG (INT_BIT > 16 ? 12 : 9) -#endif -#define BLOCKSIZE (1 << BLOCKLOG) -#define BLOCKIFY(SIZE) (((SIZE) + BLOCKSIZE - 1) / BLOCKSIZE) - -/* Determine the amount of memory spanned by the initial heap table - (not an absolute limit). */ -#define HEAP (INT_BIT > 16 ? 4194304 : 65536) - -/* Number of contiguous free blocks allowed to build up at the end of - memory before they will be returned to the system. */ -#define FINAL_FREE_BLOCKS 8 - -/* Data structure giving per-block information. */ -typedef union - { - /* Heap information for a busy block. */ - struct - { - /* Zero for a large block, or positive giving the - logarithm to the base two of the fragment size. */ - int type; - union - { - struct - { - size_t nfree; /* Free fragments in a fragmented block. */ - size_t first; /* First free fragment of the block. */ - } frag; - /* Size (in blocks) of a large cluster. */ - size_t size; - } info; - } busy; - /* Heap information for a free block - (that may be the first of a free cluster). */ - struct - { - size_t size; /* Size (in blocks) of a free cluster. */ - size_t next; /* Index of next free cluster. */ - size_t prev; /* Index of previous free cluster. */ - } free; - } malloc_info; - -/* Pointer to first block of the heap. */ -extern char *_heapbase; - -/* Table indexed by block number giving per-block information. */ -extern malloc_info *_heapinfo; - -/* Address to block number and vice versa. */ -#define BLOCK(A) (((char *) (A) - _heapbase) / BLOCKSIZE + 1) -#define ADDRESS(B) ((__ptr_t) (((B) - 1) * BLOCKSIZE + _heapbase)) - -/* Current search index for the heap table. */ -extern size_t _heapindex; - -/* Limit of valid info table indices. */ -extern size_t _heaplimit; - -/* Doubly linked lists of free fragments. */ -struct list - { - struct list *next; - struct list *prev; - }; - -/* Free list headers for each fragment size. */ -extern struct list _fraghead[]; - -/* List of blocks allocated with `memalign' (or `valloc'). */ -struct alignlist - { - struct alignlist *next; - __ptr_t aligned; /* The address that memaligned returned. */ - __ptr_t exact; /* The address that malloc returned. */ - }; -extern struct alignlist *_aligned_blocks; - -/* Instrumentation. */ -extern size_t _chunks_used; -extern size_t _bytes_used; -extern size_t _chunks_free; -extern size_t _bytes_free; - -/* Internal version of `free' used in `morecore' (malloc.c). */ -extern void _free_internal __P ((__ptr_t __ptr)); - -#endif /* _MALLOC_INTERNAL. */ - -/* Underlying allocation function; successive calls should - return contiguous pieces of memory. */ -/* It does NOT always return contiguous pieces of memory on VMS. */ -extern __ptr_t (*__morecore) __P ((ptrdiff_t __size)); - -/* Underlying deallocation function. It accepts both a pointer and - a size to back up. It is implementation dependent what is really - used. */ -extern __ptr_t (*__lesscore) __P ((__ptr_t __ptr, ptrdiff_t __size)); - -/* Default value of `__morecore'. */ -extern __ptr_t __default_morecore __P ((ptrdiff_t __size)); - -/* Default value of `__lesscore'. */ -extern __ptr_t __default_lesscore __P ((__ptr_t __ptr, ptrdiff_t __size)); - -#ifdef VMS -/* Default value of `__morecore'. */ -extern __ptr_t __vms_morecore __P ((ptrdiff_t __size)); - -/* Default value of `__lesscore'. */ -extern __ptr_t __vms_lesscore __P ((__ptr_t __ptr, ptrdiff_t __size)); -#endif - -/* If not NULL, this function is called after each time - `__morecore' is called to increase the data size. */ -extern void (*__after_morecore_hook) __P ((void)); - -/* If not NULL, this function is called after each time - `__lesscore' is called to increase the data size. */ -extern void (*__after_lesscore_hook) __P ((void)); - -/* Nonzero if `malloc' has been called and done its initialization. */ -extern int __malloc_initialized; - -/* Hooks for debugging versions. */ -extern void (*__free_hook) __P ((__ptr_t __ptr)); -extern __ptr_t (*__malloc_hook) __P ((size_t __size)); -extern __ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, size_t __size)); - -/* Activate a standard collection of debugging hooks. */ -extern int mcheck __P ((void (*__func) __P ((void)))); - -/* Activate a standard collection of tracing hooks. */ -extern void mtrace __P ((void)); - -/* Statistics available to the user. */ -struct mstats - { - size_t bytes_total; /* Total size of the heap. */ - size_t chunks_used; /* Chunks allocated by the user. */ - size_t bytes_used; /* Byte total of user-allocated chunks. */ - size_t chunks_free; /* Chunks in the free list. */ - size_t bytes_free; /* Byte total of chunks in the free list. */ - }; - -/* Pick up the current statistics. */ -extern struct mstats mstats __P ((void)); - -/* Call WARNFUN with a warning message when memory usage is high. */ -extern void memory_warnings __P ((__ptr_t __start, - void (*__warnfun) __P ((__const char *)))); - - -/* Relocating allocator. */ - -/* Allocate SIZE bytes, and store the address in *HANDLEPTR. */ -extern __ptr_t r_alloc __P ((__ptr_t *__handleptr, size_t __size)); - -/* Free the storage allocated in HANDLEPTR. */ -extern void r_alloc_free __P ((__ptr_t *__handleptr)); - -/* Adjust the block at HANDLEPTR to be SIZE bytes long. */ -extern __ptr_t r_re_alloc __P ((__ptr_t *__handleptr, size_t __size)); - - -#ifdef __cplusplus -} -#endif - -#endif /* malloc.h */ -/* Memory allocator `malloc'. - Copyright 1990, 1991, 1992, 1993 Free Software Foundation - Written May 1989 by Mike Haertel. - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public License as -published by the Free Software Foundation; either version 2 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Library General Public License for more details. - -You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. - - The author may be reached (Email) at the address mike@ai.mit.edu, - or (US mail) as Mike Haertel c/o Free Software Foundation. */ - -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include <malloc.h> -#endif - -#ifdef VMS -/* How to really get more memory. */ -__ptr_t (*__morecore) __P ((ptrdiff_t __size)) = __vms_morecore; -#else -/* How to really get more memory. */ -__ptr_t (*__morecore) __P ((ptrdiff_t __size)) = __default_morecore; -#endif - -/* Debugging hook for `malloc'. */ -#ifdef VMS -__ptr_t (*__malloc_hook) __P ((size_t __size)) = __vms_malloc; -#else -__ptr_t (*__malloc_hook) __P ((size_t __size)); -#endif - -/* Pointer to the base of the first block. */ -char *_heapbase; - -/* Block information table. Allocated with align/__free (not malloc/free). */ -malloc_info *_heapinfo; - -/* Number of info entries. */ -static size_t heapsize; - -/* Search index in the info table. */ -size_t _heapindex; - -/* Limit of valid info table indices. */ -size_t _heaplimit; - -/* Free lists for each fragment size. */ -struct list _fraghead[BLOCKLOG]; - -/* Instrumentation. */ -size_t _chunks_used; -size_t _bytes_used; -size_t _chunks_free; -size_t _bytes_free; - -/* Are you experienced? */ -int __malloc_initialized; - -void (*__after_morecore_hook) __P ((void)); - -/* Aligned allocation. */ -static __ptr_t align __P ((size_t)); -static __ptr_t -align (size) - size_t size; -{ - __ptr_t result; - unsigned long int adj; - - result = (*__morecore) (size); - adj = (unsigned long int) ((unsigned long int) ((char *) result - - (char *) NULL)) % BLOCKSIZE; - if (adj != 0) - { - adj = BLOCKSIZE - adj; - (void) (*__morecore) (adj); - result = (char *) result + adj; - } - - if (__after_morecore_hook) - (*__after_morecore_hook) (); - - return result; -} - -/* Set everything up and remember that we have. */ -static int initialize __P ((void)); -static int -initialize () -{ -#ifdef RL_DEBUG - extern VMS_present_buffer(); - printf("__malloc_initialized = %d\n", __malloc_initialized); - VMS_present_buffer(); -#endif - heapsize = HEAP / BLOCKSIZE; - _heapinfo = (malloc_info *) align (heapsize * sizeof (malloc_info)); - if (_heapinfo == NULL) - return 0; - memset (_heapinfo, 0, heapsize * sizeof (malloc_info)); - _heapinfo[0].free.size = 0; - _heapinfo[0].free.next = _heapinfo[0].free.prev = 0; - _heapindex = 0; - _heapbase = (char *) _heapinfo; -#ifdef RL_DEBUG -/* debug */ - printf("_heapbase = 0%o/0x%x/%d\n", _heapbase, _heapbase, _heapbase); -/* end debug */ -#endif - __malloc_initialized = 1; - return 1; -} - -/* Get neatly aligned memory, initializing or - growing the heap info table as necessary. */ -static __ptr_t morecore __P ((size_t)); -static __ptr_t -morecore (size) - size_t size; -{ - __ptr_t result; - malloc_info *newinfo, *oldinfo; - size_t newsize; - - result = align (size); - if (result == NULL) - return NULL; - - /* Check if we need to grow the info table. */ - if ((size_t) BLOCK ((char *) result + size) > heapsize) - { - newsize = heapsize; - while ((size_t) BLOCK ((char *) result + size) > newsize) - newsize *= 2; - newinfo = (malloc_info *) align (newsize * sizeof (malloc_info)); - if (newinfo == NULL) - { - (*__lesscore) (result, size); - return NULL; - } - memset (newinfo, 0, newsize * sizeof (malloc_info)); - memcpy (newinfo, _heapinfo, heapsize * sizeof (malloc_info)); - oldinfo = _heapinfo; - newinfo[BLOCK (oldinfo)].busy.type = 0; - newinfo[BLOCK (oldinfo)].busy.info.size - = BLOCKIFY (heapsize * sizeof (malloc_info)); - _heapinfo = newinfo; - _free_internal (oldinfo); - heapsize = newsize; - } - - _heaplimit = BLOCK ((char *) result + size); - return result; -} - -/* Allocate memory from the heap. */ -__ptr_t -malloc (size) - size_t size; -{ - __ptr_t result; - size_t block, blocks, lastblocks, start; - register size_t i; - struct list *next; - - if (size == 0) - return NULL; - - if (__malloc_hook != NULL) - return (*__malloc_hook) (size); - - if (!__malloc_initialized) - if (!initialize ()) - return NULL; - - if (size < sizeof (struct list)) - size = sizeof (struct list); - - /* Determine the allocation policy based on the request size. */ - if (size <= BLOCKSIZE / 2) - { - /* Small allocation to receive a fragment of a block. - Determine the logarithm to base two of the fragment size. */ - register size_t log = 1; - --size; - while ((size /= 2) != 0) - ++log; - - /* Look in the fragment lists for a - free fragment of the desired size. */ - next = _fraghead[log].next; - if (next != NULL) - { - /* There are free fragments of this size. - Pop a fragment out of the fragment list and return it. - Update the block's nfree and first counters. */ - result = (__ptr_t) next; - next->prev->next = next->next; - if (next->next != NULL) - next->next->prev = next->prev; - block = BLOCK (result); - if (--_heapinfo[block].busy.info.frag.nfree != 0) - _heapinfo[block].busy.info.frag.first = (unsigned long int) - ((unsigned long int) ((char *) next->next - (char *) NULL) - % BLOCKSIZE) >> log; - - /* Update the statistics. */ - ++_chunks_used; - _bytes_used += 1 << log; - --_chunks_free; - _bytes_free -= 1 << log; - } - else - { - /* No free fragments of the desired size, so get a new block - and break it into fragments, returning the first. */ - result = malloc (BLOCKSIZE); - if (result == NULL) - return NULL; - - /* Link all fragments but the first into the free list. */ - for (i = 1; i < (size_t) (BLOCKSIZE >> log); ++i) - { - next = (struct list *) ((char *) result + (i << log)); -#ifdef RL_DEBUG - printf("DEBUG: malloc (%d): next = %p\n", size, next); -#endif - next->next = _fraghead[log].next; - next->prev = &_fraghead[log]; - next->prev->next = next; - if (next->next != NULL) - next->next->prev = next; - } - - /* Initialize the nfree and first counters for this block. */ - block = BLOCK (result); - _heapinfo[block].busy.type = log; - _heapinfo[block].busy.info.frag.nfree = i - 1; - _heapinfo[block].busy.info.frag.first = i - 1; - - _chunks_free += (BLOCKSIZE >> log) - 1; - _bytes_free += BLOCKSIZE - (1 << log); - _bytes_used -= BLOCKSIZE - (1 << log); - } - } - else - { - /* Large allocation to receive one or more blocks. - Search the free list in a circle starting at the last place visited. - If we loop completely around without finding a large enough - space we will have to get more memory from the system. */ - blocks = BLOCKIFY (size); - start = block = _heapindex; - while (_heapinfo[block].free.size < blocks) - { - block = _heapinfo[block].free.next; - if (block == start) - { - /* Need to get more from the system. Check to see if - the new core will be contiguous with the final free - block; if so we don't need to get as much. */ - block = _heapinfo[0].free.prev; - lastblocks = _heapinfo[block].free.size; - if (_heaplimit != 0 && block + lastblocks == _heaplimit && - (*__morecore) (0) == ADDRESS (block + lastblocks) && - (morecore ((blocks - lastblocks) * BLOCKSIZE)) != NULL) - { - _heapinfo[block].free.size = blocks; - _bytes_free += (blocks - lastblocks) * BLOCKSIZE; - continue; - } - result = morecore (blocks * BLOCKSIZE); - if (result == NULL) - return NULL; - block = BLOCK (result); - _heapinfo[block].busy.type = 0; - _heapinfo[block].busy.info.size = blocks; - ++_chunks_used; - _bytes_used += blocks * BLOCKSIZE; - return result; - } - } - - /* At this point we have found a suitable free list entry. - Figure out how to remove what we need from the list. */ - result = ADDRESS (block); - if (_heapinfo[block].free.size > blocks) - { - /* The block we found has a bit left over, - so relink the tail end back into the free list. */ - _heapinfo[block + blocks].free.size - = _heapinfo[block].free.size - blocks; - _heapinfo[block + blocks].free.next - = _heapinfo[block].free.next; - _heapinfo[block + blocks].free.prev - = _heapinfo[block].free.prev; - _heapinfo[_heapinfo[block].free.prev].free.next - = _heapinfo[_heapinfo[block].free.next].free.prev - = _heapindex = block + blocks; - } - else - { - /* The block exactly matches our requirements, - so just remove it from the list. */ - _heapinfo[_heapinfo[block].free.next].free.prev - = _heapinfo[block].free.prev; - _heapinfo[_heapinfo[block].free.prev].free.next - = _heapindex = _heapinfo[block].free.next; - --_chunks_free; - } - - _heapinfo[block].busy.type = 0; - _heapinfo[block].busy.info.size = blocks; - ++_chunks_used; - _bytes_used += blocks * BLOCKSIZE; - _bytes_free -= blocks * BLOCKSIZE; - } - - return result; -} -/* Free a block of memory allocated by `malloc'. - Copyright 1990, 1991, 1992 Free Software Foundation - Written May 1989 by Mike Haertel. - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public License as -published by the Free Software Foundation; either version 2 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Library General Public License for more details. - -You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. - - The author may be reached (Email) at the address mike@ai.mit.edu, - or (US mail) as Mike Haertel c/o Free Software Foundation. */ - -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include <malloc.h> -#endif - -#ifdef VMS -/* How to really get more memory. */ -__ptr_t (*__lesscore) __P ((__ptr_t __ptr,ptrdiff_t __size)) = __vms_lesscore; -#else -/* How to really get more memory. */ -__ptr_t (*__lesscore) __P ((__ptr_t __ptr,ptrdiff_t __size)) = __default_lesscore; -#endif - -/* Debugging hook for free. */ -#ifdef VMS -void (*__free_hook) __P ((__ptr_t __ptr)) = __vms_free; -#else -void (*__free_hook) __P ((__ptr_t __ptr)); -#endif - -/* List of blocks allocated by memalign. */ -struct alignlist *_aligned_blocks = NULL; - -/* Return memory to the heap. - Like `free' but don't call a __free_hook if there is one. */ -void -_free_internal (ptr) - __ptr_t ptr; -{ - int type; - size_t block, blocks; - register size_t i; - struct list *prev, *next; - - block = BLOCK (ptr); - - type = _heapinfo[block].busy.type; - switch (type) - { - case 0: - /* Get as many statistics as early as we can. */ - --_chunks_used; - _bytes_used -= _heapinfo[block].busy.info.size * BLOCKSIZE; - _bytes_free += _heapinfo[block].busy.info.size * BLOCKSIZE; - - /* Find the free cluster previous to this one in the free list. - Start searching at the last block referenced; this may benefit - programs with locality of allocation. */ - i = _heapindex; - if (i > block) - while (i > block) - i = _heapinfo[i].free.prev; - else - { - do - i = _heapinfo[i].free.next; - while (i > 0 && i < block); - i = _heapinfo[i].free.prev; - } - - /* Determine how to link this block into the free list. */ - if (block == i + _heapinfo[i].free.size) - { - /* Coalesce this block with its predecessor. */ - _heapinfo[i].free.size += _heapinfo[block].busy.info.size; - block = i; - } - else - { - /* Really link this block back into the free list. */ - _heapinfo[block].free.size = _heapinfo[block].busy.info.size; - _heapinfo[block].free.next = _heapinfo[i].free.next; - _heapinfo[block].free.prev = i; - _heapinfo[i].free.next = block; - _heapinfo[_heapinfo[block].free.next].free.prev = block; - ++_chunks_free; - } - - /* Now that the block is linked in, see if we can coalesce it - with its successor (by deleting its successor from the list - and adding in its size). */ - if (block + _heapinfo[block].free.size == _heapinfo[block].free.next) - { - _heapinfo[block].free.size - += _heapinfo[_heapinfo[block].free.next].free.size; - _heapinfo[block].free.next - = _heapinfo[_heapinfo[block].free.next].free.next; - _heapinfo[_heapinfo[block].free.next].free.prev = block; - --_chunks_free; - } - - /* Now see if we can return stuff to the system. */ - blocks = _heapinfo[block].free.size; - if (blocks >= FINAL_FREE_BLOCKS && block + blocks == _heaplimit - && (*__morecore) (0) == ADDRESS (block + blocks)) - { - register size_t bytes = blocks * BLOCKSIZE; - _heaplimit -= blocks; - (*__lesscore) (ADDRESS(block), bytes); - _heapinfo[_heapinfo[block].free.prev].free.next - = _heapinfo[block].free.next; - _heapinfo[_heapinfo[block].free.next].free.prev - = _heapinfo[block].free.prev; - block = _heapinfo[block].free.prev; - --_chunks_free; - _bytes_free -= bytes; - } - - /* Set the next search to begin at this block. */ - _heapindex = block; - break; - - default: - /* Do some of the statistics. */ - --_chunks_used; - _bytes_used -= 1 << type; - ++_chunks_free; - _bytes_free += 1 << type; - - /* Get the address of the first free fragment in this block. */ - prev = (struct list *) ((char *) ADDRESS (block) + - (_heapinfo[block].busy.info.frag.first << type)); -#ifdef RL_DEBUG - printf("_free_internal(0%o/0x%x/%d) :\n", ptr, ptr, ptr); - printf(" block = %d, type = %d, prev = 0%o/0x%x/%d\n", - block, type, prev, prev, prev); - printf(" _heapinfo[block=%d].busy.info.frag.nfree = %d\n", - block, - _heapinfo[block].busy.info.frag.nfree); -#endif - - if (_heapinfo[block].busy.info.frag.nfree == (BLOCKSIZE >> type) - 1) - { - /* If all fragments of this block are free, remove them - from the fragment list and free the whole block. */ - next = prev; - for (i = 1; i < (size_t) (BLOCKSIZE >> type); ++i) - next = next->next; - prev->prev->next = next; - if (next != NULL) - next->prev = prev->prev; - _heapinfo[block].busy.type = 0; - _heapinfo[block].busy.info.size = 1; - - /* Keep the statistics accurate. */ - ++_chunks_used; - _bytes_used += BLOCKSIZE; - _chunks_free -= BLOCKSIZE >> type; - _bytes_free -= BLOCKSIZE; - - free (ADDRESS (block)); - } - else if (_heapinfo[block].busy.info.frag.nfree != 0) - { - /* If some fragments of this block are free, link this - fragment into the fragment list after the first free - fragment of this block. */ -#ifdef RL_DEBUG - printf("There's a bug hiding here (%s:%d), so I will print some values\n", __FILE__, __LINE__); -#endif - next = (struct list *) ptr; -#ifdef RL_DEBUG - printf(" (struct list *)next (0%o / 0x%x / %d) ->\n", next, next, next); - printf(" next = 0%o / 0x%x / %d\n", next->next,next->next,next->next); - printf(" prev = 0%o / 0x%x / %d\n", next->prev,next->prev,next->prev); - printf(" (struct list *)prev (0%o / 0x%x / %d)->\n", prev, prev, prev); - printf(" next = 0%o / 0x%x / %d\n", prev->next,prev->next,prev->next); - printf(" prev = 0%o / 0x%x / %d\n", prev->prev,prev->prev,prev->prev); -#endif - next->next = prev->next; - next->prev = prev; - prev->next = next; - if (next->next != NULL) - next->next->prev = next; - ++_heapinfo[block].busy.info.frag.nfree; - } - else - { - /* No fragments of this block are free, so link this - fragment into the fragment list and announce that - it is the first free fragment of this block. */ - prev = (struct list *) ptr; - _heapinfo[block].busy.info.frag.nfree = 1; - _heapinfo[block].busy.info.frag.first = (unsigned long int) - ((unsigned long int) ((char *) ptr - (char *) NULL) - % BLOCKSIZE >> type); - prev->next = _fraghead[type].next; - prev->prev = &_fraghead[type]; - prev->prev->next = prev; - if (prev->next != NULL) - prev->next->prev = prev; - } - break; - } -} - -/* Return memory to the heap. */ -void -free (ptr) - __ptr_t ptr; -{ - register struct alignlist *l; - - if (ptr == NULL) - return; - - for (l = _aligned_blocks; l != NULL; l = l->next) - if (l->aligned == ptr) - { - l->aligned = NULL; /* Mark the slot in the list as free. */ - ptr = l->exact; - break; - } - - if (__free_hook != NULL) - (*__free_hook) (ptr); - else - _free_internal (ptr); -} -/* Change the size of a block allocated by `malloc'. - Copyright 1990, 1991, 1992, 1993 Free Software Foundation, Inc. - Written May 1989 by Mike Haertel. - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public License as -published by the Free Software Foundation; either version 2 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Library General Public License for more details. - -You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. - - The author may be reached (Email) at the address mike@ai.mit.edu, - or (US mail) as Mike Haertel c/o Free Software Foundation. */ - -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include <malloc.h> -#endif - -#define min(A, B) ((A) < (B) ? (A) : (B)) - -/* Debugging hook for realloc. */ -#ifdef VMS -__ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, size_t __size)) = __vms_realloc; -#else -__ptr_t (*__realloc_hook) __P ((__ptr_t __ptr, size_t __size)); -#endif - -/* Resize the given region to the new size, returning a pointer - to the (possibly moved) region. This is optimized for speed; - some benchmarks seem to indicate that greater compactness is - achieved by unconditionally allocating and copying to a - new region. This module has incestuous knowledge of the - internals of both free and malloc. */ -__ptr_t -realloc (ptr, size) - __ptr_t ptr; - size_t size; -{ - __ptr_t result; - int type; - size_t block, blocks, oldlimit; - - if (size == 0) - { - free (ptr); - return malloc (0); - } - else if (ptr == NULL) - return malloc (size); - - if (__realloc_hook != NULL) - return (*__realloc_hook) (ptr, size); - - block = BLOCK (ptr); - - type = _heapinfo[block].busy.type; - switch (type) - { - case 0: - /* Maybe reallocate a large block to a small fragment. */ - if (size <= BLOCKSIZE / 2) - { - result = malloc (size); - if (result != NULL) - { - memcpy (result, ptr, size); - free (ptr); - return result; - } - } - - /* The new size is a large allocation as well; - see if we can hold it in place. */ - blocks = BLOCKIFY (size); - if (blocks < _heapinfo[block].busy.info.size) - { - /* The new size is smaller; return - excess memory to the free list. */ - _heapinfo[block + blocks].busy.type = 0; - _heapinfo[block + blocks].busy.info.size - = _heapinfo[block].busy.info.size - blocks; - _heapinfo[block].busy.info.size = blocks; - free (ADDRESS (block + blocks)); - result = ptr; - } - else if (blocks == _heapinfo[block].busy.info.size) - /* No size change necessary. */ - result = ptr; - else - { - /* Won't fit, so allocate a new region that will. - Free the old region first in case there is sufficient - adjacent free space to grow without moving. */ - blocks = _heapinfo[block].busy.info.size; - /* Prevent free from actually returning memory to the system. */ - oldlimit = _heaplimit; - _heaplimit = 0; - free (ptr); - _heaplimit = oldlimit; - result = malloc (size); - if (result == NULL) - { - /* Now we're really in trouble. We have to unfree - the thing we just freed. Unfortunately it might - have been coalesced with its neighbors. */ - if (_heapindex == block) - (void) malloc (blocks * BLOCKSIZE); - else - { - __ptr_t previous = malloc ((block - _heapindex) * BLOCKSIZE); - (void) malloc (blocks * BLOCKSIZE); - free (previous); - } - return NULL; - } - if (ptr != result) - memmove (result, ptr, blocks * BLOCKSIZE); - } - break; - - default: - /* Old size is a fragment; type is logarithm - to base two of the fragment size. */ - if (size > (size_t) (1 << (type - 1)) && size <= (size_t) (1 << type)) - /* The new size is the same kind of fragment. */ - result = ptr; - else - { - /* The new size is different; allocate a new space, - and copy the lesser of the new size and the old. */ - result = malloc (size); - if (result == NULL) - return NULL; - memcpy (result, ptr, min (size, (size_t) 1 << type)); - free (ptr); - } - break; - } - - return result; -} -/* Copyright (C) 1991, 1992 Free Software Foundation, Inc. - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public License as -published by the Free Software Foundation; either version 2 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Library General Public License for more details. - -You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. - - The author may be reached (Email) at the address mike@ai.mit.edu, - or (US mail) as Mike Haertel c/o Free Software Foundation. */ - -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include <malloc.h> -#endif - -/* Allocate an array of NMEMB elements each SIZE bytes long. - The entire array is initialized to zeros. */ -__ptr_t -calloc (nmemb, size) - register size_t nmemb; - register size_t size; -{ - register __ptr_t result = malloc (nmemb * size); - - if (result != NULL) - (void) memset (result, 0, nmemb * size); - - return result; -} -/* Copyright (C) 1991, 1992 Free Software Foundation, Inc. -This file is part of the GNU C Library. - -The GNU C Library is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -The GNU C Library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with the GNU C Library; see the file COPYING. If not, write to -the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include <malloc.h> -#endif - -#ifndef __GNU_LIBRARY__ -#define __sbrk sbrk -#ifdef VMS -#define __brk brk -#endif -#endif - -extern __ptr_t __sbrk __P ((int increment)); - -#ifndef NULL -#define NULL 0 -#endif - -#if defined(emacs) && defined(VMS) -/* Dumping of Emacs on VMS does not include the heap! - So let's make a huge array from which initial data will be - allocated. - - VMS_ALLOCATION_SIZE is the amount of memory we preallocate. - We don't want it to be too large, because it only gives a larger - dump file. The way to check how much is really used is to - make VMS_ALLOCATION_SIZE very large, to link Emacs with the - debugger, run Emacs, check how much was allocated. Then set - VMS_ALLOCATION_SIZE to something suitable, recompile gmalloc, - relink Emacs, and you should be off. - - N.B. This is experimental, but it worked quite fine on Emacs 18. -*/ -#ifndef VMS_ALLOCATION_SIZE -#define VMS_ALLOCATION_SIZE (512*(512+128)) -#endif - -int vms_out_initial = 0; -char vms_initial_buffer[VMS_ALLOCATION_SIZE]; -char *vms_current_brk = vms_initial_buffer; -char *vms_end_brk = &vms_initial_buffer[VMS_ALLOCATION_SIZE-1]; - -__ptr_t -__vms_initial_morecore (increment) - ptrdiff_t increment; -{ - __ptr_t result = NULL; - __ptr_t temp; - - /* It's far easier to make the alignment here than to make a - kludge in align () */ -#ifdef RL_DEBUG - printf(">>>foo... %p...", vms_current_brk); -#endif - vms_current_brk += (BLOCKSIZE - ((unsigned long) vms_current_brk - & (BLOCKSIZE - 1))) & (BLOCKSIZE - 1); -#ifdef RL_DEBUG - printf("bar... %p. (%d)\n", vms_current_brk, increment); -#endif - temp = vms_current_brk + (int) increment; - if (temp <= vms_end_brk) - { - if (increment >= 0) - result = vms_current_brk; - else - result = temp; - vms_current_brk = temp; - } - return result; -} - -__ptr_t -__vms_initial_lesscore (ptr, size) - __ptr_t ptr; - ptrdiff_t size; -{ - if (ptr >= vms_initial_buffer - && ptr < vms_initial_buffer+VMS_ALLOCATION_SIZE) - { - vms_current_brk = ptr; - return vms_current_brk; - } - return vms_current_brk; -} - -VMS_present_buffer() -{ - printf("Vms initial buffer starts at 0%o/0x%x/%d and ends at 0%o/0x%x/%d\n", - vms_initial_buffer, vms_initial_buffer, vms_initial_buffer, - vms_end_brk, vms_end_brk, vms_end_brk); -} -#endif /* defined(emacs) && defined(VMS) */ - -#ifdef VMS -/* Unfortunately, the VAX C sbrk() is buggy. For example, it returns - memory in 512 byte chunks (not a bug, but there's more), AND it - adds an extra 512 byte chunk if you ask for a multiple of 512 - bytes (you ask for 512 bytes, you get 1024 bytes...). And also, - the VAX C sbrk does not handle negative increments... - There's a similar problem with brk(). Even if you set the break - to an even page boundary, it gives you one extra page... */ - -static char vms_brk_info_fetched = -1; /* -1 if this is the first time, otherwise - bit 0 set if 'increment' needs adjustment - bit 1 set if the value to brk() needs adjustment */ -static char *vms_brk_start = 0; -static char *vms_brk_end = 0; -static char *vms_brk_current = 0; -#endif - -/* Allocate INCREMENT more bytes of data space, - and return the start of data space, or NULL on errors. - If INCREMENT is negative, shrink data space. */ -__ptr_t -__default_morecore (increment) - ptrdiff_t increment; -{ - __ptr_t result; -#ifdef VMS - __ptr_t temp; - -#ifdef RL_DEBUG - printf("DEBUG: morecore: increment = %x\n", increment); - printf(" @ start: vms_brk_info_fetched = %x\n", vms_brk_info_fetched); - printf(" vms_brk_start = %p\n", vms_brk_start); - printf(" vms_brk_current = %p\n", vms_brk_current); - printf(" vms_brk_end = %p\n", vms_brk_end); - printf(" @ end: "); -#endif - - if (vms_brk_info_fetched < 0) - { - vms_brk_current = vms_brk_start = __sbrk (512); - vms_brk_end = __sbrk (0); - if (vms_brk_end - vms_brk_current == 1024) - vms_brk_info_fetched = 1; - else - vms_brk_info_fetched = 0; - vms_brk_end = brk(vms_brk_start); - if (vms_brk_end != vms_brk_start) - vms_brk_info_fetched |= 2; -#ifdef RL_DEBUG - printf("vms_brk_info_fetched = %x\n", vms_brk_info_fetched); - printf(" vms_brk_start = %p\n", vms_brk_start); - printf(" vms_brk_current = %p\n", vms_brk_current); - printf(" vms_brk_end = %p\n", vms_brk_end); - printf(" "); -#endif - } - - if (increment < 0) - { - printf("BZZZZZT! ERROR: __default_morecore does NOT take negative args\n"); - return NULL; - } - - if (increment > 0) - { - result = vms_brk_current; - temp = vms_brk_current + increment; - - if (temp > vms_brk_end) - { - __ptr_t foo; - - foo = __sbrk (0); - if (foo == vms_brk_end) - { - increment = temp - vms_brk_end; - if (increment > (vms_brk_info_fetched & 1)) - increment -= (vms_brk_info_fetched & 1); - foo = __sbrk(increment); -#ifdef RL_DEBUG - printf("__sbrk(%d) --> %p\n", increment, foo); -#endif - if (foo == (__ptr_t) -1) - return NULL; -#ifdef RL_DEBUG - printf(" "); -#endif - } - else - { - result = __sbrk (increment); - - if (result == (__ptr_t) -1) - return NULL; - - temp = result + increment; - } - - vms_brk_end = __sbrk(0); - } - vms_brk_current = temp; -#ifdef RL_DEBUG - printf("vms_brk_current = %p\n", vms_brk_current); - printf(" vms_brk_end = %p\n", vms_brk_end); -#endif - return result; - } -#ifdef RL_DEBUG - printf(" nothing more...\n"); -#endif - - /* OK, so the user wanted to check where the heap limit is. Let's - see if the system thinks it is where we think it is. */ - temp = __sbrk (0); - if (temp != vms_brk_end) - { - /* the value has changed. - Let's trust the system and modify our value */ - vms_brk_current = vms_brk_end = temp; - } - return vms_brk_current; - -#else /* not VMS */ - result = __sbrk ((int) increment); - if (result == (__ptr_t) -1) - return NULL; - return result; -#endif /* VMS */ -} - -__ptr_t -__default_lesscore (ptr, size) - __ptr_t ptr; - ptrdiff_t size; -{ -#ifdef VMS - if (vms_brk_end != 0) - { - vms_brk_current = ptr; - if (vms_brk_current < vms_brk_start) - vms_brk_current = vms_brk_start; - vms_brk_end = (char *) vms_brk_current - - ((vms_brk_info_fetched >> 1) & 1); -#ifdef RL_DEBUG - printf("<<<bar... %p (%p (%p, %d))...", - vms_brk_end, vms_brk_current, ptr, size); -#endif - vms_brk_end = __brk (vms_brk_end); -#ifdef RL_DEBUG - printf("foo... %p.\n", vms_brk_end); -#endif - } - - return vms_brk_current; -#else /* not VMS */ - __default_morecore (-size); -#endif -} - -/* Allocate memory on a page boundary. - Copyright (C) 1991, 1992 Free Software Foundation, Inc. - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public License as -published by the Free Software Foundation; either version 2 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Library General Public License for more details. - -You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. - - The author may be reached (Email) at the address mike@ai.mit.edu, - or (US mail) as Mike Haertel c/o Free Software Foundation. */ - -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include <malloc.h> -#endif - -#if defined (emacs) || defined (HAVE_CONFIG_H) -#include "config.h" -#endif - -#ifdef __GNU_LIBRARY__ -extern size_t __getpagesize __P ((void)); -#else -#if !defined(USG) && !defined(VMS) -extern size_t getpagesize __P ((void)); -#define __getpagesize() getpagesize() -#else -#include <sys/param.h> -#ifdef EXEC_PAGESIZE -#define __getpagesize() EXEC_PAGESIZE -#else /* No EXEC_PAGESIZE. */ -#ifdef NBPG -#ifndef CLSIZE -#define CLSIZE 1 -#endif /* No CLSIZE. */ -#define __getpagesize() (NBPG * CLSIZE) -#else /* No NBPG. */ -#define __getpagesize() NBPC -#endif /* NBPG. */ -#endif /* EXEC_PAGESIZE. */ -#endif /* USG. */ -#endif - -static size_t pagesize; - -__ptr_t -valloc (size) - size_t size; -{ - if (pagesize == 0) - pagesize = __getpagesize (); - - return memalign (pagesize, size); -} -/* Copyright (C) 1991, 1992 Free Software Foundation, Inc. - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public License as -published by the Free Software Foundation; either version 2 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Library General Public License for more details. - -You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. */ - -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include <malloc.h> -#endif - -__ptr_t -memalign (alignment, size) - size_t alignment; - size_t size; -{ - __ptr_t result; - unsigned long int adj; - - size = ((size + alignment - 1) / alignment) * alignment; - - result = malloc (size); - if (result == NULL) - return NULL; - adj = (unsigned long int) ((unsigned long int) ((char *) result - - (char *) NULL)) % alignment; - if (adj != 0) - { - struct alignlist *l; - for (l = _aligned_blocks; l != NULL; l = l->next) - if (l->aligned == NULL) - /* This slot is free. Use it. */ - break; - if (l == NULL) - { - l = (struct alignlist *) malloc (sizeof (struct alignlist)); - if (l == NULL) - { - free (result); - return NULL; - } - } - l->exact = result; - result = l->aligned = (char *) result + alignment - adj; - l->next = _aligned_blocks; - _aligned_blocks = l; - } - - return result; -} - -#ifdef VMS -struct vms_malloc_data -{ - int __malloc_initialized; - char *_heapbase; - malloc_info *_heapinfo; - size_t heapsize; - size_t _heapindex; - size_t _heaplimit; - size_t _chunks_used; - size_t _bytes_used; - size_t _chunks_free; - size_t _bytes_free; -} ____vms_malloc_data[] = -{ - { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }, - { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 } -}; - -struct vms_core_routines -{ - __ptr_t (*__morecore) __P ((ptrdiff_t increment)); - __ptr_t (*__lesscore) __P ((__ptr_t address, ptrdiff_t increment)); -} ____vms_core_routines[] = -{ - { __vms_initial_morecore, __vms_initial_lesscore }, - { __default_morecore, __default_lesscore }, - { 0, 0 } -}; - -static int current_vms_data = -1; -static int current_vms_core_routines = 0; - -static void use_vms_core_routines (int i) -{ - current_vms_core_routines = i; - current_vms_data = i; -} - -static void use_vms_data (int i) -{ - use_vms_core_routines (i); - __malloc_initialized = ____vms_malloc_data[i].__malloc_initialized; - _heapbase = ____vms_malloc_data[i]._heapbase; - _heapinfo = ____vms_malloc_data[i]._heapinfo; - heapsize = ____vms_malloc_data[i].heapsize; - _heapindex = ____vms_malloc_data[i]._heapindex; - _heaplimit = ____vms_malloc_data[i]._heaplimit; - _chunks_used = ____vms_malloc_data[i]._chunks_used; - _bytes_used = ____vms_malloc_data[i]._bytes_used; - _chunks_free = ____vms_malloc_data[i]._chunks_free; - _bytes_free = ____vms_malloc_data[i]._bytes_free; -} - -static void store_vms_data (int i) -{ - ____vms_malloc_data[i].__malloc_initialized = __malloc_initialized; - ____vms_malloc_data[i]._heapbase = _heapbase; - ____vms_malloc_data[i]._heapinfo = _heapinfo; - ____vms_malloc_data[i].heapsize = heapsize; - ____vms_malloc_data[i]._heapindex = _heapindex; - ____vms_malloc_data[i]._heaplimit = _heaplimit; - ____vms_malloc_data[i]._chunks_used = _chunks_used; - ____vms_malloc_data[i]._bytes_used = _bytes_used; - ____vms_malloc_data[i]._chunks_free = _chunks_free; - ____vms_malloc_data[i]._bytes_free = _bytes_free; -} - -static void store_current_vms_data () -{ - switch (current_vms_data) - { - case 0: - case 1: - store_vms_data (current_vms_data); - break; - } -} - -__ptr_t __vms_morecore (increment) - ptrdiff_t increment; -{ - return - (*____vms_core_routines[current_vms_core_routines].__morecore) (increment); -} - -__ptr_t __vms_lesscore (ptr, increment) - __ptr_t ptr; - ptrdiff_t increment; -{ - return - (*____vms_core_routines[current_vms_core_routines].__lesscore) (ptr,increment); -} - -__ptr_t __vms_malloc (size) - size_t size; -{ - __ptr_t result; - int old_current_vms_data = current_vms_data; - - __malloc_hook = 0; - - store_current_vms_data (); - - if (____vms_malloc_data[0]._heapbase != 0) - use_vms_data (0); - else - use_vms_core_routines (0); - result = malloc (size); - store_vms_data (0); - if (result == NULL) - { - use_vms_data (1); - result = malloc (size); - store_vms_data (1); - vms_out_initial = 1; - } - __malloc_hook = __vms_malloc; - if (old_current_vms_data != -1) - use_vms_data (current_vms_data); - return result; -} - -void __vms_free (ptr) - __ptr_t ptr; -{ - int old_current_vms_data = current_vms_data; - - __free_hook = 0; - - store_current_vms_data (); - - if (ptr >= vms_initial_buffer && ptr <= vms_end_brk) - { - use_vms_data (0); - free (ptr); - store_vms_data (0); - } - else - { - use_vms_data (1); - free (ptr); - store_vms_data (1); - if (_chunks_free == 0 && _chunks_used == 0) - vms_out_initial = 0; - } - __free_hook = __vms_free; - if (old_current_vms_data != -1) - use_vms_data (current_vms_data); -} - -__ptr_t __vms_realloc (ptr, size) - __ptr_t ptr; - size_t size; -{ - __ptr_t result; - int old_current_vms_data = current_vms_data; - - __realloc_hook = 0; - - store_current_vms_data (); - - if (ptr >= vms_initial_buffer && ptr <= vms_end_brk) - { - use_vms_data (0); - result = realloc (ptr, size); - store_vms_data (0); - } - else - { - use_vms_data (1); - result = realloc (ptr, size); - store_vms_data (1); - } - __realloc_hook = __vms_realloc; - if (old_current_vms_data != -1) - use_vms_data (current_vms_data); - return result; -} -#endif /* VMS */ -/* Standard debugging hooks for `malloc'. - Copyright 1990, 1991, 1992 Free Software Foundation - Written May 1989 by Mike Haertel. - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public License as -published by the Free Software Foundation; either version 2 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Library General Public License for more details. - -You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. - - The author may be reached (Email) at the address mike@ai.mit.edu, - or (US mail) as Mike Haertel c/o Free Software Foundation. */ - -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include <malloc.h> -#endif - -/* Old hook values. */ -static void (*old_free_hook) __P ((__ptr_t ptr)); -static __ptr_t (*old_malloc_hook) __P ((size_t size)); -static __ptr_t (*old_realloc_hook) __P ((__ptr_t ptr, size_t size)); - -/* Function to call when something awful happens. */ -static void (*abortfunc) __P ((void)); - -/* Arbitrary magical numbers. */ -#define MAGICWORD 0xfedabeeb -#define MAGICBYTE ((char) 0xd7) - -struct hdr - { - size_t size; /* Exact size requested by user. */ - unsigned long int magic; /* Magic number to check header integrity. */ - }; - -static void checkhdr __P ((__const struct hdr *)); -static void -checkhdr (hdr) - __const struct hdr *hdr; -{ - if (hdr->magic != MAGICWORD || ((char *) &hdr[1])[hdr->size] != MAGICBYTE) - (*abortfunc) (); -} - -static void freehook __P ((__ptr_t)); -static void -freehook (ptr) - __ptr_t ptr; -{ - struct hdr *hdr = ((struct hdr *) ptr) - 1; - checkhdr (hdr); - hdr->magic = 0; - __free_hook = old_free_hook; - free (hdr); - __free_hook = freehook; -} - -static __ptr_t mallochook __P ((size_t)); -static __ptr_t -mallochook (size) - size_t size; -{ - struct hdr *hdr; - - __malloc_hook = old_malloc_hook; - hdr = (struct hdr *) malloc (sizeof (struct hdr) + size + 1); - __malloc_hook = mallochook; - if (hdr == NULL) - return NULL; - - hdr->size = size; - hdr->magic = MAGICWORD; - ((char *) &hdr[1])[size] = MAGICBYTE; - return (__ptr_t) (hdr + 1); -} - -static __ptr_t reallochook __P ((__ptr_t, size_t)); -static __ptr_t -reallochook (ptr, size) - __ptr_t ptr; - size_t size; -{ - struct hdr *hdr = ((struct hdr *) ptr) - 1; - - checkhdr (hdr); - __free_hook = old_free_hook; - __malloc_hook = old_malloc_hook; - __realloc_hook = old_realloc_hook; - hdr = (struct hdr *) realloc ((__ptr_t) hdr, sizeof (struct hdr) + size + 1); - __free_hook = freehook; - __malloc_hook = mallochook; - __realloc_hook = reallochook; - if (hdr == NULL) - return NULL; - - hdr->size = size; - ((char *) &hdr[1])[size] = MAGICBYTE; - return (__ptr_t) (hdr + 1); -} - -int -mcheck (func) - void (*func) __P ((void)); -{ - extern void abort __P ((void)); - static int mcheck_used = 0; - - abortfunc = (func != NULL) ? func : abort; - - /* These hooks may not be safely inserted if malloc is already in use. */ - if (!__malloc_initialized && !mcheck_used) - { - old_free_hook = __free_hook; - __free_hook = freehook; - old_malloc_hook = __malloc_hook; - __malloc_hook = mallochook; - old_realloc_hook = __realloc_hook; - __realloc_hook = reallochook; - mcheck_used = 1; - } - - return mcheck_used ? 0 : -1; -} -/* More debugging hooks for `malloc'. - Copyright (C) 1991, 1992 Free Software Foundation, Inc. - Written April 2, 1991 by John Gilmore of Cygnus Support. - Based on mcheck.c by Mike Haertel. - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public License as -published by the Free Software Foundation; either version 2 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Library General Public License for more details. - -You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. - - The author may be reached (Email) at the address mike@ai.mit.edu, - or (US mail) as Mike Haertel c/o Free Software Foundation. */ - -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include <malloc.h> -#endif - -#include <stdio.h> - -#ifndef __GNU_LIBRARY__ -extern char *getenv (); -#else -#include <stdlib.h> -#endif - -static FILE *mallstream; -static char mallenv[]= "MALLOC_TRACE"; -static char mallbuf[BUFSIZ]; /* Buffer for the output. */ - -/* Address to breakpoint on accesses to... */ -__ptr_t mallwatch; - -/* Old hook values. */ -static __ptr_t (*tr_old_morecore) __P ((ptrdiff_t increment)); -static __ptr_t (*tr_old_lesscore) __P ((__ptr_t ptr, ptrdiff_t increment)); -static void (*tr_old_free_hook) __P ((__ptr_t ptr)); -static __ptr_t (*tr_old_malloc_hook) __P ((size_t size)); -static __ptr_t (*tr_old_realloc_hook) __P ((__ptr_t ptr, size_t size)); - -/* This function is called when the block being alloc'd, realloc'd, or - freed has an address matching the variable "mallwatch". In a debugger, - set "mallwatch" to the address of interest, then put a breakpoint on - tr_break. */ - -void tr_break __P ((void)); -void -tr_break () -{ -} - -static void tr_freehook __P ((__ptr_t)); -static void -tr_freehook (ptr) - __ptr_t ptr; -{ - fprintf (mallstream, "- %p\n", ptr); /* Be sure to print it first. */ - if (ptr == mallwatch) - tr_break (); - __free_hook = tr_old_free_hook; - free (ptr); - __free_hook = tr_freehook; -} - -static __ptr_t tr_morecore __P ((ptrdiff_t)); -static __ptr_t -tr_morecore (increment) - ptrdiff_t increment; -{ - __ptr_t p; - - __morecore = tr_old_morecore; - p = (__ptr_t) (*__morecore) (increment); - __morecore = tr_morecore; - - fprintf (mallstream, "$ %p %d\n", p, increment); - - return p; -} - -static __ptr_t tr_lesscore __P ((__ptr_t, ptrdiff_t)); -static __ptr_t -tr_lesscore (ptr, increment) - __ptr_t ptr; - ptrdiff_t increment; -{ - __ptr_t p; - - __lesscore = tr_old_lesscore; - p = (__ptr_t) (*__lesscore) (ptr, increment); - __lesscore = tr_lesscore; - - fprintf (mallstream, "* %p (%p, %d)\n", p, ptr, increment); - - return p; -} - -static __ptr_t tr_mallochook __P ((size_t)); -static __ptr_t -tr_mallochook (size) - size_t size; -{ - __ptr_t hdr; - - __malloc_hook = tr_old_malloc_hook; - hdr = (__ptr_t) malloc (size); - __malloc_hook = tr_mallochook; - - /* We could be printing a NULL here; that's OK. */ - fprintf (mallstream, "+ %p %x\n", hdr, size); - - if (hdr == mallwatch) - tr_break (); - - return hdr; -} - -static __ptr_t tr_reallochook __P ((__ptr_t, size_t)); -static __ptr_t -tr_reallochook (ptr, size) - __ptr_t ptr; - size_t size; -{ - __ptr_t hdr; - - if (ptr == mallwatch) - tr_break (); - - __free_hook = tr_old_free_hook; - __malloc_hook = tr_old_malloc_hook; - __realloc_hook = tr_old_realloc_hook; - hdr = (__ptr_t) realloc (ptr, size); - __free_hook = tr_freehook; - __malloc_hook = tr_mallochook; - __realloc_hook = tr_reallochook; - if (hdr == NULL) - /* Failed realloc. */ - fprintf (mallstream, "! %p %x\n", ptr, size); - else - fprintf (mallstream, "< %p\n> %p %x\n", ptr, hdr, size); - - if (hdr == mallwatch) - tr_break (); - - return hdr; -} - -/* We enable tracing if either the environment variable MALLOC_TRACE - is set, or if the variable mallwatch has been patched to an address - that the debugging user wants us to stop on. When patching mallwatch, - don't forget to set a breakpoint on tr_break! */ - -void -mtrace () -{ - char *mallfile; - - mallfile = getenv (mallenv); - if (mallfile != NULL || mallwatch != NULL) - { - mallstream = fopen (mallfile != NULL ? mallfile : "/dev/null", "w"); - if (mallstream != NULL) - { - /* Be sure it doesn't malloc its buffer! */ - setbuf (mallstream, mallbuf); - fprintf (mallstream, "= Start\n"); -#if defined(emacs) && defined(VMS) - fprintf (mallstream, "= Initial buffer spans %p -- %p\n", - vms_initial_buffer, vms_end_brk + 1); -#endif - tr_old_morecore = __morecore; - __morecore = tr_morecore; - tr_old_lesscore = __lesscore; - __lesscore = tr_lesscore; - tr_old_free_hook = __free_hook; - __free_hook = tr_freehook; - tr_old_malloc_hook = __malloc_hook; - __malloc_hook = tr_mallochook; - tr_old_realloc_hook = __realloc_hook; - __realloc_hook = tr_reallochook; - } - } -} -/* Access the statistics maintained by `malloc'. - Copyright 1990, 1991, 1992 Free Software Foundation - Written May 1989 by Mike Haertel. - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public License as -published by the Free Software Foundation; either version 2 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Library General Public License for more details. - -You should have received a copy of the GNU Library General Public -License along with this library; see the file COPYING.LIB. If -not, write to the Free Software Foundation, Inc., 675 Mass Ave, -Cambridge, MA 02139, USA. - - The author may be reached (Email) at the address mike@ai.mit.edu, - or (US mail) as Mike Haertel c/o Free Software Foundation. */ - -#ifndef _MALLOC_INTERNAL -#define _MALLOC_INTERNAL -#include <malloc.h> -#endif - -struct mstats -mstats () -{ - struct mstats result; - - result.bytes_total = (char *) (*__morecore) (0) - _heapbase; - result.chunks_used = _chunks_used; - result.bytes_used = _bytes_used; - result.chunks_free = _chunks_free; - result.bytes_free = _bytes_free; - return result; -}
--- a/src/vmsmap.c Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,225 +0,0 @@ -/* VMS mapping of data and alloc arena for GNU Emacs. - Copyright (C) 1986, 1987 Free Software Foundation, Inc. - - This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -/* Written by Mukesh Prasad. */ - -#ifdef VMS - -#include <config.h> -#include "lisp.h" -#include <rab.h> -#include <fab.h> -#include <rmsdef.h> -#include <secdef.h> - -/* RMS block size */ -#define BLOCKSIZE 512 - -/* Maximum number of bytes to be written in one RMS write. - * Must be a multiple of BLOCKSIZE. - */ -#define MAXWRITE (BLOCKSIZE * 30) - -/* This funniness is to ensure that sdata occurs alphabetically BEFORE the - $DATA psect and that edata occurs after ALL Emacs psects. This is - because the VMS linker sorts all psects in a cluster alphabetically - during the linking, unless you use the cluster_psect command. Emacs - uses the cluster command to group all Emacs psects into one cluster; - this keeps the dumped data separate from any loaded libraries. */ - -globaldef {"$D$ATA"} char sdata[512]; /* Start of saved data area */ -globaldef {"__DATA"} char edata[512]; /* End of saved data area */ - -/* Structure to write into first block of map file. - */ - -struct map_data -{ - char * sdata; /* Start of data area */ - char * edata; /* End of data area */ - int datablk; /* Block in file to map data area from/to */ -}; - -static void fill_fab (), fill_rab (); -static int write_data (); - -extern char *start_of_data (); -extern int vms_out_initial; /* Defined in malloc.c */ - -/* Maps in the data and alloc area from the map file. - */ - -int -mapin_data (name) - char * name; -{ - struct FAB fab; - struct RAB rab; - int status, size; - int inadr[2]; - struct map_data map_data; - - /* Open map file. */ - fab = cc$rms_fab; - fab.fab$b_fac = FAB$M_BIO|FAB$M_GET; - fab.fab$l_fna = name; - fab.fab$b_fns = strlen (name); - status = sys$open (&fab); - if (status != RMS$_NORMAL) - { - printf ("Map file not available, running bare Emacs....\n"); - return 0; /* Map file not available */ - } - /* Connect the RAB block */ - rab = cc$rms_rab; - rab.rab$l_fab = &fab; - rab.rab$b_rac = RAB$C_SEQ; - rab.rab$l_rop = RAB$M_BIO; - status = sys$connect (&rab); - if (status != RMS$_NORMAL) - lib$stop (status); - /* Read the header data */ - rab.rab$l_ubf = &map_data; - rab.rab$w_usz = sizeof (map_data); - rab.rab$l_bkt = 0; - status = sys$read (&rab); - if (status != RMS$_NORMAL) - lib$stop (status); - status = sys$close (&fab); - if (status != RMS$_NORMAL) - lib$stop (status); - if (map_data.sdata != start_of_data ()) - { - printf ("Start of data area has moved: cannot map in data.\n"); - return 0; - } - if (map_data.edata != edata) - { - printf ("End of data area has moved: cannot map in data.\n"); - return 0; - } - fab.fab$l_fop |= FAB$M_UFO; - status = sys$open (&fab); - if (status != RMS$_NORMAL) - lib$stop (status); - /* Map data area. */ - inadr[0] = map_data.sdata; - inadr[1] = map_data.edata; - status = sys$crmpsc (inadr, 0, 0, SEC$M_CRF | SEC$M_WRT, 0, 0, 0, - fab.fab$l_stv, 0, map_data.datablk, 0, 0); - if (! (status & 1)) - lib$stop (status); -} - -/* Writes the data and alloc area to the map file. - */ -mapout_data (into) - char * into; -{ - struct FAB fab; - struct RAB rab; - int status; - struct map_data map_data; - int datasize, msize; - - if (vms_out_initial) - { - error ("Out of initial allocation. Must rebuild emacs with more memory (VMS_ALLOCATION_SIZE)."); - return 0; - } - map_data.sdata = start_of_data (); - map_data.edata = edata; - datasize = map_data.edata - map_data.sdata + 1; - map_data.datablk = 2 + (sizeof (map_data) + BLOCKSIZE - 1) / BLOCKSIZE; - /* Create map file. */ - fab = cc$rms_fab; - fab.fab$b_fac = FAB$M_BIO|FAB$M_PUT; - fab.fab$l_fna = into; - fab.fab$b_fns = strlen (into); - fab.fab$l_fop = FAB$M_CBT; - fab.fab$b_org = FAB$C_SEQ; - fab.fab$b_rat = 0; - fab.fab$b_rfm = FAB$C_VAR; - fab.fab$l_alq = 1 + map_data.datablk + - ((datasize + BLOCKSIZE - 1) / BLOCKSIZE); - status = sys$create (&fab); - if (status != RMS$_NORMAL) - { - error ("Could not create map file"); - return 0; - } - /* Connect the RAB block */ - rab = cc$rms_rab; - rab.rab$l_fab = &fab; - rab.rab$b_rac = RAB$C_SEQ; - rab.rab$l_rop = RAB$M_BIO; - status = sys$connect (&rab); - if (status != RMS$_NORMAL) - { - error ("RMS connect to map file failed"); - return 0; - } - /* Write the header */ - rab.rab$l_rbf = &map_data; - rab.rab$w_rsz = sizeof (map_data); - status = sys$write (&rab); - if (status != RMS$_NORMAL) - { - error ("RMS write (header) to map file failed"); - return 0; - } - if (! write_data (&rab, map_data.datablk, map_data.sdata, datasize)) - return 0; - status = sys$close (&fab); - if (status != RMS$_NORMAL) - { - error ("RMS close on map file failed"); - return 0; - } - return 1; -} - -static int -write_data (rab, firstblock, data, length) - struct RAB * rab; - char * data; -{ - int status; - - rab->rab$l_bkt = firstblock; - while (length > 0) - { - rab->rab$l_rbf = data; - rab->rab$w_rsz = length > MAXWRITE ? MAXWRITE : length; - status = sys$write (rab, 0, 0); - if (status != RMS$_NORMAL) - { - error ("RMS write to map file failed"); - return 0; - } - data = &data[MAXWRITE]; - length -= MAXWRITE; - rab->rab$l_bkt = 0; - } - return 1; -} /* write_data */ - -#endif /* VMS */ -
--- a/src/vmspaths.h Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -/* Hey Emacs, this is -*- C -*- code! */ - -/* The default search path for Lisp function "load". - This sets load-path. */ -#define PATH_LOADSEARCH "EMACS_LIBRARY:[LOCAL-LISP],EMACS_LIBRARY:[LISP]" - -/* Like PATH_LOADSEARCH, but used only when Emacs is dumping. This - path is usually identical to PATH_LOADSEARCH except that the entry - for the directory containing the installed lisp files has been - replaced with ../lisp. */ -#define PATH_DUMPLOADSEARCH "[-.LISP]" - -/* The extra search path for programs to invoke. This is appended to - whatever the PATH environment variable says to set the Lisp - variable exec-path and the first file name in it sets the Lisp - variable exec-directory. exec-directory is used for finding - executables and other architecture-dependent files. */ -#define PATH_EXEC "EMACS_LIBRARY:[LIB-SRC]" - -/* Where Emacs should look for its architecture-independent data - files, like the docstring file. The lisp variable data-directory - is set to this value. */ -#define PATH_DATA "EMACS_LIBRARY:[ETC]" - -/* the name of the directory that contains lock files - with which we record what files are being modified in Emacs. - This directory should be writable by everyone. */ -#define PATH_LOCK "EMACS_LIBRARY:[LOCK]" - -/* the name of the file !!!SuperLock!!! in the directory - specified by PATH_LOCK. Yes, this is redundant. */ -#define PATH_SUPERLOCK "EMACS_LIBRARY:[LOCK]$$$SUPERLOCK$$$."
--- a/src/vmsproc.c Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,795 +0,0 @@ -/* Interfaces to subprocesses on VMS. - Copyright (C) 1988, 1994 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - - -/* - Event flag and `select' emulation - - 0 is never used - 1 is the terminal - 23 is the timer event flag - 24-31 are reserved by VMS -*/ -#include <config.h> -#include <ssdef.h> -#include <iodef.h> -#include <dvidef.h> -#include <clidef.h> -#include "vmsproc.h" -#include "lisp.h" -#include "buffer.h" -#include <file.h> -#include "process.h" -#include "commands.h" -#include <errno.h> -extern Lisp_Object call_process_cleanup (); - - -#define KEYBOARD_EVENT_FLAG 1 -#define TIMER_EVENT_FLAG 23 - -static VMS_PROC_STUFF procList[MAX_EVENT_FLAGS+1]; - -get_kbd_event_flag () -{ - /* - Return the first event flag for keyboard input. - */ - VMS_PROC_STUFF *vs = &procList[KEYBOARD_EVENT_FLAG]; - - vs->busy = 1; - vs->pid = 0; - return (vs->eventFlag); -} - -get_timer_event_flag () -{ - /* - Return the last event flag for use by timeouts - */ - VMS_PROC_STUFF *vs = &procList[TIMER_EVENT_FLAG]; - - vs->busy = 1; - vs->pid = 0; - return (vs->eventFlag); -} - -VMS_PROC_STUFF * -get_vms_process_stuff () -{ - /* - Return a process_stuff structure - - We use 1-23 as our event flags to simplify implementing - a VMS `select' call. - */ - int i; - VMS_PROC_STUFF *vs; - - for (i=1, vs = procList; i<MAX_EVENT_FLAGS; i++, vs++) - { - if (!vs->busy) - { - vs->busy = 1; - vs->inputChan = 0; - vs->pid = 0; - sys$clref (vs->eventFlag); - return (vs); - } - } - return ((VMS_PROC_STUFF *)0); -} - -give_back_vms_process_stuff (vs) - VMS_PROC_STUFF *vs; -{ - /* - Return an event flag to our pool - */ - vs->busy = 0; - vs->inputChan = 0; - vs->pid = 0; -} - -VMS_PROC_STUFF * -get_vms_process_pointer (pid) - int pid; -{ - /* - Given a pid, return the VMS_STUFF pointer - */ - int i; - VMS_PROC_STUFF *vs; - - /* Don't search the last one */ - for (i=0, vs=procList; i<MAX_EVENT_FLAGS; i++, vs++) - { - if (vs->busy && vs->pid == pid) - return (vs); - } - return ((VMS_PROC_STUFF *)0); -} - -start_vms_process_read (vs) - VMS_PROC_STUFF *vs; -{ - /* - Start an asynchronous read on a VMS process - We will catch up with the output sooner or later - */ - int status; - int ProcAst (); - - status = sys$qio (vs->eventFlag, vs->outputChan, IO$_READVBLK, - vs->iosb, 0, vs, - vs->inputBuffer, sizeof (vs->inputBuffer), 0, 0, 0, 0); - if (status != SS$_NORMAL) - return (0); - else - return (1); -} - -extern int waiting_for_ast; /* in sysdep.c */ -extern int timer_ef; -extern int input_ef; - -select (nDesc, rdsc, wdsc, edsc, timeOut) - int nDesc; - int *rdsc; - int *wdsc; - int *edsc; - int *timeOut; -{ - /* Emulate a select call - - We know that we only use event flags 1-23 - - timeout == 100000 & bit 0 set means wait on keyboard input until - something shows up. If timeout == 0, we just read the event - flags and return what we find. */ - - int nfds = 0; - int status; - int time[2]; - int delta = -10000000; - int zero = 0; - int timeout = *timeOut; - unsigned long mask, readMask, waitMask; - - if (rdsc) - readMask = *rdsc << 1; /* Unix mask is shifted over 1 */ - else - readMask = 0; /* Must be a wait call */ - - sys$clref (KEYBOARD_EVENT_FLAG); - sys$setast (0); /* Block interrupts */ - sys$readef (KEYBOARD_EVENT_FLAG, &mask); /* See what is set */ - mask &= readMask; /* Just examine what we need */ - if (mask == 0) - { /* Nothing set, we must wait */ - if (timeout != 0) - { /* Not just inspecting... */ - if (!(timeout == 100000 && - readMask == (1 << KEYBOARD_EVENT_FLAG))) - { - lib$emul (&timeout, &delta, &zero, time); - sys$setimr (TIMER_EVENT_FLAG, time, 0, 1); - waitMask = readMask | (1 << TIMER_EVENT_FLAG); - } - else - waitMask = readMask; - if (waitMask & (1 << KEYBOARD_EVENT_FLAG)) - { - sys$clref (KEYBOARD_EVENT_FLAG); - waiting_for_ast = 1; /* Only if reading from 0 */ - } - sys$setast (1); - sys$wflor (KEYBOARD_EVENT_FLAG, waitMask); - sys$cantim (1, 0); - sys$readef (KEYBOARD_EVENT_FLAG, &mask); - if (readMask & (1 << KEYBOARD_EVENT_FLAG)) - waiting_for_ast = 0; - } - } - sys$setast (1); - - /* - Count number of descriptors that are ready - */ - mask &= readMask; - if (rdsc) - *rdsc = (mask >> 1); /* Back to Unix format */ - for (nfds = 0; mask; mask >>= 1) - { - if (mask & 1) - nfds++; - } - return (nfds); -} - -#define MAX_BUFF 1024 - -write_to_vms_process (vs, buf, len) - VMS_PROC_STUFF *vs; - char *buf; - int len; -{ - /* - Write something to a VMS process. - - We have to map newlines to carriage returns for VMS. - */ - char ourBuff[MAX_BUFF]; - short iosb[4]; - int status; - int in, out; - - while (len > 0) - { - out = map_nl_to_cr (buf, ourBuff, len, MAX_BUFF); - status = sys$qiow (0, vs->inputChan, IO$_WRITEVBLK|IO$M_NOFORMAT, - iosb, 0, 0, ourBuff, out, 0, 0, 0, 0); - if (status != SS$_NORMAL || (status = iosb[0]) != SS$_NORMAL) - { - error ("Could not write to subprocess: %x", status); - return (0); - } - len -= out; - } - return (1); -} - -static -map_nl_to_cr (in, out, maxIn, maxOut) - char *in; - char *out; - int maxIn; - int maxOut; -{ - /* - Copy `in' to `out' remapping `\n' to `\r' - */ - int c; - int o; - - for (o=0; maxIn-- > 0 && o < maxOut; o++) - { - c = *in++; - *out++ = (c == '\n') ? '\r' : c; - } - return (o); -} - -clean_vms_buffer (buf, len) - char *buf; - int len; -{ - /* - Sanitize output from a VMS subprocess - Strip CR's and NULLs - */ - char *oBuf = buf; - char c; - int l = 0; - - while (len-- > 0) - { - c = *buf++; - if (c == '\r' || c == '\0') - ; - else - { - *oBuf++ = c; - l++; - } - } - return (l); -} - -/* - For the CMU PTY driver -*/ -#define PTYNAME "PYA0:" - -get_pty_channel (inDevName, outDevName, inChannel, outChannel) - char *inDevName; - char *outDevName; - int *inChannel; - int *outChannel; -{ - int PartnerUnitNumber; - int status; - struct { - int l; - char *a; - } d; - struct { - short BufLen; - short ItemCode; - int *BufAddress; - int *ItemLength; - } g[2]; - - d.l = strlen (PTYNAME); - d.a = PTYNAME; - *inChannel = 0; /* Should be `short' on VMS */ - *outChannel = 0; - *inDevName = *outDevName = '\0'; - status = sys$assign (&d, inChannel, 0, 0); - if (status == SS$_NORMAL) - { - *outChannel = *inChannel; - g[0].BufLen = sizeof (PartnerUnitNumber); - g[0].ItemCode = DVI$_UNIT; - g[0].BufAddress = &PartnerUnitNumber; - g[0].ItemLength = (int *)0; - g[1].BufLen = g[1].ItemCode = 0; - status = sys$getdviw (0, *inChannel, 0, &g, 0, 0, 0, 0); - if (status == SS$_NORMAL) - { - sprintf (inDevName, "_TPA%d:", PartnerUnitNumber); - strcpy (outDevName, inDevName); - } - } - return (status); -} - -VMSgetwd (buf) - char *buf; -{ - /* - Return the current directory - */ - char curdir[256]; - char *getenv (); - char *s; - short len; - int status; - struct - { - int l; - char *a; - } d; - - s = getenv ("SYS$DISK"); - if (s) - strcpy (buf, s); - else - *buf = '\0'; - - d.l = 255; - d.a = curdir; - status = sys$setddir (0, &len, &d); - if (status & 1) - { - curdir[len] = '\0'; - strcat (buf, curdir); - } -} - -static -call_process_ast (vs) - VMS_PROC_STUFF *vs; -{ - sys$setef (vs->eventFlag); -} - -void -child_setup (in, out, err, new_argv, env) - int in, out, err; - register char **new_argv; - char **env; -{ - /* ??? I suspect that maybe this shouldn't be done on VMS. */ -#ifdef subprocesses - /* Close Emacs's descriptors that this process should not have. */ - close_process_descs (); -#endif - - if (STRINGP (current_buffer->directory)) - chdir (XSTRING (current_buffer->directory)->data); -} - -DEFUN ("call-process", Fcall_process, Scall_process, 1, MANY, 0, - "Call PROGRAM synchronously in a separate process.\n\ -Program's input comes from file INFILE (nil means null device, `NLA0:').\n\ -Insert output in BUFFER before point; t means current buffer;\n\ - nil for BUFFER means discard it; 0 means discard and don't wait.\n\ -Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.\n\ -Remaining arguments are strings passed as command arguments to PROGRAM.\n\ -This function waits for PROGRAM to terminate, unless BUFFER is 0;\n\ -if you quit, the process is killed.") - (nargs, args) - int nargs; - register Lisp_Object *args; -{ - Lisp_Object display, buffer, path; - char oldDir[512]; - int inchannel, outchannel; - int len; - int call_process_ast (); - struct - { - int l; - char *a; - } dcmd, din, dout; - char inDevName[65]; - char outDevName[65]; - short iosb[4]; - int status; - int SpawnFlags = CLI$M_NOWAIT; - VMS_PROC_STUFF *vs; - VMS_PROC_STUFF *get_vms_process_stuff (); - int fd[2]; - int filefd; - register int pid; - char buf[1024]; - int count = specpdl_ptr - specpdl; - register unsigned char **new_argv; - struct buffer *old = current_buffer; - - CHECK_STRING (args[0], 0); - - if (nargs <= 1 || NILP (args[1])) - args[1] = build_string ("NLA0:"); - else - args[1] = Fexpand_file_name (args[1], current_buffer->directory); - - CHECK_STRING (args[1], 1); - - { - register Lisp_Object tem; - buffer = tem = args[2]; - if (nargs <= 2) - buffer = Qnil; - else if (!(EQ (tem, Qnil) || EQ (tem, Qt) - || XFASTINT (tem) == 0)) - { - buffer = Fget_buffer (tem); - CHECK_BUFFER (buffer, 2); - } - } - - display = nargs >= 3 ? args[3] : Qnil; - - { - /* - if (args[0] == "*dcl*" then we need to skip pas the "-c", - else args[0] is the program to run. - */ - register int i; - int arg0; - int firstArg; - - if (strcmp (XSTRING (args[0])->data, "*dcl*") == 0) - { - arg0 = 5; - firstArg = 6; - } - else - { - arg0 = 0; - firstArg = 4; - } - len = XSTRING (args[arg0])->size + 1; - for (i = firstArg; i < nargs; i++) - { - CHECK_STRING (args[i], i); - len += XSTRING (args[i])->size + 1; - } - new_argv = alloca (len); - strcpy (new_argv, XSTRING (args[arg0])->data); - for (i = firstArg; i < nargs; i++) - { - strcat (new_argv, " "); - strcat (new_argv, XSTRING (args[i])->data); - } - dcmd.l = len-1; - dcmd.a = new_argv; - - status = get_pty_channel (inDevName, outDevName, &inchannel, &outchannel); - if (!(status & 1)) - error ("Error getting PTY channel: %x", status); - if (INTEGERP (buffer)) - { - dout.l = strlen ("NLA0:"); - dout.a = "NLA0:"; - } - else - { - dout.l = strlen (outDevName); - dout.a = outDevName; - } - - vs = get_vms_process_stuff (); - if (!vs) - { - sys$dassgn (inchannel); - sys$dassgn (outchannel); - error ("Too many VMS processes"); - } - vs->inputChan = inchannel; - vs->outputChan = outchannel; - } - - filefd = open (XSTRING (args[1])->data, O_RDONLY, 0); - if (filefd < 0) - { - sys$dassgn (inchannel); - sys$dassgn (outchannel); - give_back_vms_process_stuff (vs); - report_file_error ("Opening process input file", Fcons (args[1], Qnil)); - } - else - close (filefd); - - din.l = XSTRING (args[1])->size; - din.a = XSTRING (args[1])->data; - - /* - Start a read on the process channel - */ - if (!INTEGERP (buffer)) - { - start_vms_process_read (vs); - SpawnFlags = CLI$M_NOWAIT; - } - else - SpawnFlags = 0; - - /* - On VMS we need to change the current directory - of the parent process before forking so that - the child inherit that directory. We remember - where we were before changing. - */ - VMSgetwd (oldDir); - child_setup (0, 0, 0, 0, 0); - status = lib$spawn (&dcmd, &din, &dout, &SpawnFlags, 0, &vs->pid, - &vs->exitStatus, 0, call_process_ast, vs); - chdir (oldDir); - - if (status != SS$_NORMAL) - { - sys$dassgn (inchannel); - sys$dassgn (outchannel); - give_back_vms_process_stuff (vs); - error ("Error calling LIB$SPAWN: %x", status); - } - pid = vs->pid; - - if (INTEGERP (buffer)) - { -#ifndef subprocesses - wait_without_blocking (); -#endif subprocesses - return Qnil; - } - - if (!NILP (display) && INTERACTIVE) - prepare_menu_bars (); - - record_unwind_protect (call_process_cleanup, - Fcons (make_number (fd[0]), make_number (pid))); - - - if (BUFFERP (buffer)) - Fset_buffer (buffer); - - immediate_quit = 1; - QUIT; - - while (1) - { - sys$waitfr (vs->eventFlag); - if (vs->iosb[0] & 1) - { - immediate_quit = 0; - if (!NILP (buffer)) - { - vs->iosb[1] = clean_vms_buffer (vs->inputBuffer, vs->iosb[1]); - InsCStr (vs->inputBuffer, vs->iosb[1]); - } - if (!NILP (display) && INTERACTIVE) - redisplay_preserve_echo_area (19); - immediate_quit = 1; - QUIT; - if (!start_vms_process_read (vs)) - break; /* The other side went away */ - } - else - break; - } - - sys$dassgn (inchannel); - sys$dassgn (outchannel); - give_back_vms_process_stuff (vs); - - /* Wait for it to terminate, unless it already has. */ - wait_for_termination (pid); - - immediate_quit = 0; - - set_current_buffer (old); - - return unbind_to (count, Qnil); -} - -create_process (process, new_argv) - Lisp_Object process; - char *new_argv; -{ - int pid, inchannel, outchannel, forkin, forkout; - char old_dir[512]; - char in_dev_name[65]; - char out_dev_name[65]; - short iosb[4]; - int status; - int spawn_flags = CLI$M_NOWAIT; - int child_sig (); - struct { - int l; - char *a; - } din, dout, dprompt, dcmd; - VMS_PROC_STUFF *vs; - VMS_PROC_STUFF *get_vms_process_stuff (); - - status = get_pty_channel (in_dev_name, out_dev_name, &inchannel, &outchannel); - if (!(status & 1)) - { - remove_process (process); - error ("Error getting PTY channel: %x", status); - } - dout.l = strlen (out_dev_name); - dout.a = out_dev_name; - dprompt.l = strlen (DCL_PROMPT); - dprompt.a = DCL_PROMPT; - - if (strcmp (new_argv, "*dcl*") == 0) - { - din.l = strlen (in_dev_name); - din.a = in_dev_name; - dcmd.l = 0; - dcmd.a = (char *)0; - } - else - { - din.l = strlen ("NLA0:"); - din.a = "NLA0:"; - dcmd.l = strlen (new_argv); - dcmd.a = new_argv; - } - - /* Delay interrupts until we have a chance to store - the new fork's pid in its process structure */ - sys$setast (0); - - vs = get_vms_process_stuff (); - if (vs == 0) - { - sys$setast (1); - remove_process (process); - error ("Too many VMS processes"); - } - vs->inputChan = inchannel; - vs->outputChan = outchannel; - - /* Start a read on the process channel */ - start_vms_process_read (vs); - - /* Switch current directory so that the child inherits it. */ - VMSgetwd (old_dir); - child_setup (0, 0, 0, 0, 0); - - status = lib$spawn (&dcmd, &din, &dout, &spawn_flags, 0, &vs->pid, - &vs->exitStatus, 0, child_sig, vs, &dprompt); - chdir (old_dir); - - if (status != SS$_NORMAL) - { - sys$setast (1); - remove_process (process); - error ("Error calling LIB$SPAWN: %x", status); - } - vs->pid &= 0xffff; /* It needs to fit in a FASTINT, - we don't need the rest of the bits */ - pid = vs->pid; - - /* - ON VMS process->infd holds the (event flag-1) - that we use for doing I/O on that process. - `input_wait_mask' is the cluster of event flags - we can wait on. - - Event flags returned start at 1 for the keyboard. - Since Unix expects descriptor 0 for the keyboard, - we subtract one from the event flag. - */ - inchannel = vs->eventFlag-1; - - /* Record this as an active process, with its channels. - As a result, child_setup will close Emacs's side of the pipes. */ - chan_process[inchannel] = process; - XSETFASTINT (XPROCESS (process)->infd, inchannel); - XSETFASTINT (XPROCESS (process)->outfd, outchannel); - XPROCESS (process)->status = Qrun - - /* Delay interrupts until we have a chance to store - the new fork's pid in its process structure */ - -#define NO_ECHO "set term/noecho\r" - sys$setast (0); - /* - Send a command to the process to not echo input - - The CMU PTY driver does not support SETMODEs. - */ - write_to_vms_process (vs, NO_ECHO, strlen (NO_ECHO)); - - XSETFASTINT (XPROCESS (process)->pid, pid); - sys$setast (1); -} - -child_sig (vs) - VMS_PROC_STUFF *vs; -{ - register int pid; - Lisp_Object tail, proc; - register struct Lisp_Process *p; - int old_errno = errno; - - pid = vs->pid; - sys$setef (vs->eventFlag); - - for (tail = Vprocess_alist; ! NILP (tail); tail = XCDR (tail)) - { - proc = XCDR (XCAR (tail)); - p = XPROCESS (proc); - if (EQ (p->childp, Qt) && XFASTINT (p->pid) == pid) - break; - } - - if (NILP (tail)) - return; - - p->status = Fcons (Qexit, Fcons (make_number (vs->exitStatus), Qnil)) -} - -syms_of_vmsproc () -{ - defsubr (&Scall_process); -} - -init_vmsproc () -{ - char *malloc (); - int i; - VMS_PROC_STUFF *vs; - - for (vs=procList, i=0; i<MAX_EVENT_FLAGS+1; i++, vs++) - { - vs->busy = 0; - vs->eventFlag = i; - sys$clref (i); - vs->inputChan = 0; - vs->pid = 0; - } - procList[0].busy = 1; /* Zero is reserved */ -}
--- a/src/vmsproc.h Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,21 +0,0 @@ -/* - Structure for storing VMS specific information for an EMACS process - - We use the event flags 1-23 for processes, keyboard input and timer -*/ - -/* - Same as MAXDESC in process.c -*/ -#define MAX_EVENT_FLAGS 23 - -typedef struct { - char inputBuffer[1024]; - short inputChan; - short outputChan; - short busy; - int pid; - int eventFlag; - int exitStatus; - short iosb[4]; -} VMS_PROC_STUFF;
--- a/src/vmstime.c Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,377 +0,0 @@ -/* Time support for VMS. - Copyright (C) 1993 Free Software Foundation. - -This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#include <config.h> -#include "vmstime.h" - -long timezone=0; -int daylight=0; - -static char tzname_default[20]=""; -static char tzname_dst[20]=""; - -char *tzname[2] = { tzname_default, tzname_dst }; - -static long internal_daylight=0; -static char daylight_set=0; - -static long read_time(const char *nptr, const char **endptr, - int sign_allowed_p) -{ - int t; - - *endptr = nptr; - - /* This routine trusts the user very much, and does no checks! - The only exception is this: */ - if (!sign_allowed_p && (*nptr == '-' || *nptr == '+')) - return 0; - - t = strtol(*endptr, endptr, 10) * 3600; - if (**endptr != ':' || **endptr == '+' || **endptr == '-') - return t; - (*endptr)++; - - t = t + strtol(*endptr, endptr, 10) * 60; - if (**endptr != ':' || **endptr == '+' || **endptr == '-') - return t; - (*endptr)++; - - return t + strtol(*endptr, endptr, 10); -} - -static void read_dst_time(const char *nptr, const char **endptr, - int *m, int *n, int *d, - int *leap_p) -{ - time_t bintim = time(0); - struct tm *lc = localtime(&bintim); - - *leap_p = 1; - *m = 0; /* When m and n are 0, a Julian */ - *n = 0; /* date has been inserted in d */ - - switch(*nptr) - { - case 'M': - { - /* This routine counts on the user to have specified "Mm.n.d", - where 1 <= n <= 5, 1 <= m <= 12, 0 <= d <= 6 */ - - *m = strtol(++nptr, endptr, 10); - (*endptr)++; /* Skip the dot */ - *n = strtol(*endptr, endptr, 10); - (*endptr)++; /* Skip the dot */ - *d = strtol(*endptr, endptr, 10); - - return; - } - case 'J': - *leap_p = 0; /* Never count with leap years */ - default: /* trust the user to have inserted a number! */ - *d = strtol(++nptr, endptr, 10); - return; - } -} - -struct vms_vectim -{ - short year, month, day, hour, minute, second, centi_second; -}; -static void find_dst_time(int m, int n, long d, - int hour, int minute, int second, - int leap_p, - long vms_internal_time[2]) -{ - long status = SYS$GETTIM(vms_internal_time); - struct vms_vectim vms_vectime; - status = SYS$NUMTIM(&vms_vectime, vms_internal_time); - - if (m == 0 && n == 0) - { - long tmp_vms_internal_time[2][2]; - long day_of_year; - long tmp_operation = LIB$K_DAY_OF_YEAR; - - status = LIB$CVT_FROM_INTERNAL_TIME(&tmp_operation, &day_of_year, - vms_internal_time); - - vms_vectime.month = 2; - vms_vectime.day = 29; - status = LIB$CVT_VECTIM(&vms_vectime, tmp_vms_internal_time[0]); - if (status & 1) /* This is a leap year */ - { - if (!leap_p && d > 59) - d ++; /* If we don't count with 29th Feb, - and this is a leap year, count up, - to make day 60 really become the - 1st March. */ - } - /* 1st January, at midnight */ - vms_vectime.month = 1; - vms_vectime.day = 1; - vms_vectime.hour = hour; - vms_vectime.minute = minute; - vms_vectime.second = second; - vms_vectime.centi_second = 0; - status = LIB$CVT_VECTIM(&vms_vectime, tmp_vms_internal_time[0]); - tmp_operation = LIB$K_DELTA_DAYS; - status = LIB$CVT_TO_INTERNAL_TIME(&tmp_operation, &d, - tmp_vms_internal_time[1]); - /* now, tmp_vms_interval_time[0] contains 1st Jan, 00:00:00, - and tmp_vms_interval_time[1] contains delta time +d days. - Let's just add them together */ - status = LIB$ADD_TIMES(tmp_vms_internal_time[0], - tmp_vms_internal_time[1], - vms_internal_time); - } - else - { - long tmp_vms_internal_time[2]; - long day_of_week; - long tmp_operation = LIB$K_DAY_OF_YEAR; - - if (d == 0) /* 0 is Sunday, which isn't compatible with VMS, - where day_of_week is 1 -- 7, and 1 is Monday */ - { - d = 7; /* So a simple conversion is required */ - } - vms_vectime.month = m; - vms_vectime.day = 1; - vms_vectime.hour = hour; - vms_vectime.minute = minute; - vms_vectime.second = second; - vms_vectime.centi_second = 0; - status = LIB$CVT_VECTIM(&vms_vectime, tmp_vms_internal_time); - tmp_operation = LIB$K_DAY_OF_WEEK; - status = LIB$CVT_FROM_INTERNAL_TIME(&tmp_operation, &day_of_week, - tmp_vms_internal_time); - d -= day_of_week; - if (d < 0) - { - d += 7; - } - vms_vectime.day += (n-1)*7 + d; - status = LIB$CVT_VECTIM(&vms_vectime, vms_internal_time); - if (!(status & 1)) - { - vms_vectime.day -= 7; /* n was probably 5 */ - status = LIB$CVT_VECTIM(&vms_vectime, vms_internal_time); - } - } -} - -static cmp_vms_internal_times(long vms_internal_time1[2], - long vms_internal_time2[2]) -{ - if (vms_internal_time1[1] < vms_internal_time2[1]) - return -1; - else - if (vms_internal_time1[1] > vms_internal_time2[1]) - return 1; - - if (vms_internal_time1[0] < vms_internal_time2[0]) - return -1; - else - if (vms_internal_time1[0] > vms_internal_time2[0]) - return 1; - - return 0; -} - -/* -------------------------- Global routines ------------------------------ */ - -#ifdef tzset -#undef tzset -#endif -void sys_tzset() -{ - char *TZ; - char *p, *q; - - if (daylight_set) - return; - - daylight = 0; - - if ((TZ = getenv("TZ")) == 0) - return; - - p = TZ; - q = tzname[0]; - - while(*p != '\0' - && (*p <'0' || *p > '9') && *p != '-' && *p != '+' && *p != ',') - *q++ = *p++; - *q = '\0'; - - /* This is special for VMS, so I don't care if it doesn't exist anywhere - else */ - - timezone = read_time(p, &p, 1); - - q = tzname[1]; - - while(*p != '\0' - && (*p <'0' || *p > '9') && *p != '-' && *p != '+' && *p != ',') - *q++ = *p++; - *q = '\0'; - - if (*p != '-' && *p != '+' && !(*p >='0' && *p <= '9')) - internal_daylight = timezone - 3600; - else - internal_daylight = read_time(p, &p, 1); - - if (*p == ',') - { - int start_m; - int start_n; - int start_d; - int start_leap_p; - int start_hour=2, start_minute=0, start_second=0; - - p++; - read_dst_time(p, &p, &start_m, &start_n, &start_d, &start_leap_p); - if (*p == '/') - { - long tmp = read_time (++p, &p, 0); - start_hour = tmp / 3600; - start_minute = (tmp % 3600) / 60; - start_second = tmp % 60; - } - if (*p == ',') - { - int end_m; - int end_n; - int end_d; - int end_leap_p; - int end_hour=2, end_minute=0, end_second=0; - - p++; - read_dst_time(p, &p, &end_m, &end_n, &end_d, &end_leap_p); - if (*p == '/') - { - long tmp = read_time (++p, &p, 0); - end_hour = tmp / 3600; - end_minute = (tmp % 3600) / 60; - end_second = tmp % 60; - } - { - long vms_internal_time[3][2]; - find_dst_time(start_m, start_n, start_d, - start_hour, start_minute, start_second, - start_leap_p, - vms_internal_time[0]); - SYS$GETTIM(&vms_internal_time[1]); - find_dst_time(end_m, end_n, end_d, - end_hour, end_minute, end_second, - end_leap_p, - vms_internal_time[2]); - if (cmp_vms_internal_times(vms_internal_time[0], - vms_internal_time[1]) < 0 - && cmp_vms_internal_times(vms_internal_time[1], - vms_internal_time[2]) < 0) - daylight = 1; - } - } - } -} - -#ifdef localtime -#undef localtime -#endif -struct tm *sys_localtime(time_t *clock) -{ - struct tm *tmp = localtime(clock); - - sys_tzset(); - tmp->tm_isdst = daylight; - - return tmp; -} - -#ifdef gmtime -#undef gmtime -#endif -struct tm *sys_gmtime(time_t *clock) -{ - static struct tm gmt; - struct vms_vectim tmp_vectime; - long vms_internal_time[3][2]; - long tmp_operation = LIB$K_DELTA_SECONDS; - long status; - long tmp_offset; - char tmp_o_sign; - - sys_tzset(); - - if (daylight) - tmp_offset = internal_daylight; - else - tmp_offset = timezone; - - if (tmp_offset < 0) - { - tmp_o_sign = -1; - tmp_offset = -tmp_offset; - } - else - tmp_o_sign = 1; - - status = LIB$CVT_TO_INTERNAL_TIME(&tmp_operation, &tmp_offset, - vms_internal_time[1]); - status = SYS$GETTIM(vms_internal_time[0]); - if (tmp_o_sign < 0) - { - status = LIB$SUB_TIMES(vms_internal_time[0], - vms_internal_time[1], - vms_internal_time[2]); - } - else - { - status = LIB$ADD_TIMES(vms_internal_time[0], - vms_internal_time[1], - vms_internal_time[2]); - } - - status = SYS$NUMTIM(&tmp_vectime, vms_internal_time[2]); - gmt.tm_sec = tmp_vectime.second; - gmt.tm_min = tmp_vectime.minute; - gmt.tm_hour = tmp_vectime.hour; - gmt.tm_mday = tmp_vectime.day; - gmt.tm_mon = tmp_vectime.month - 1; - gmt.tm_year = tmp_vectime.year - 1900; - - tmp_operation = LIB$K_DAY_OF_WEEK; - status = LIB$CVT_FROM_INTERNAL_TIME(&tmp_operation, - &gmt.tm_wday, - vms_internal_time[2]); - if (gmt.tm_wday == 7) gmt.tm_wday = 0; - - tmp_operation = LIB$K_DAY_OF_YEAR; - status = LIB$CVT_FROM_INTERNAL_TIME(&tmp_operation, - &gmt.tm_yday, - vms_internal_time[2]); - gmt.tm_yday--; - gmt.tm_isdst = daylight; - - return &gmt; -} -
--- a/src/vmstime.h Thu Feb 22 11:56:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,35 +0,0 @@ -/* Interface to time support for VMS. - Copyright (C) 1993 Free Software Foundation. - -This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -#ifndef vmstime_h -#define vmstime_h - -#include <time.h> -#include <libdtdef.h> - -extern long timezone; -extern int daylight; -extern char *tzname[2]; - -void sys_tzset(); -struct tm *sys_localtime(time_t *clock); -struct tm *sys_gmtime(time_t *clock); - -#endif /* vmstime_h */