mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-31 09:20:54 -08:00
Code Issues Projects Releases Wiki Activity

*** empty log message ***

Browse source
This commit is contained in:
Gerd Moellmann 2001-02-22 12:01:57 +00:00
parent 7c0be49625
commit 3473f362e6
16 changed files with 16 additions and 4977 deletions
Download patch file Download diff file Expand all files Collapse all files

12
lisp/ChangeLog
View file

@ -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

4
src/ChangeLog
View file

@ -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

116
src/unexencap.c
View file

@ -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);
}

16
src/unexfx2800.c
View file

@ -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");
}

243
src/vms-pp.c
View file

@ -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);
}

10
src/vms-pp.trans
View file

@ -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

35
src/vms-pwd.h
View file

@ -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 */

98
src/vmsdir.h
View file

@ -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

962
src/vmsfns.c
View file

@ -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 */

2012
src/vmsgmalloc.c
View file

File diff suppressed because it is too large Load diff

225
src/vmsmap.c
View file

@ -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 */

32
src/vmspaths.h
View file

@ -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$$$."

795
src/vmsproc.c
View file

@ -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 */
}

21
src/vmsproc.h
View file

@ -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;

377
src/vmstime.c
View file

@ -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;
}

35
src/vmstime.h
View file

@ -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 */