linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Works now under OSF1 and Linux

Browse Source
This commit is contained in:
cvs
2002-01-24 15:01:19 +00:00
parent 213a6f2f00
commit 2378909981
11 changed files with 607 additions and 228 deletions
Download Patch File Download Diff File Expand all files Collapse all files

136
tecs/err_handling.c
View File

@ -1,136 +0,0 @@
#include <assert.h>
#include <string.h>
#include <stdlib.h>
#include "sys_util.h"
#include "str_util.h"
#include "err_handling.h"
#define SLEN 64
#define MLEN 64
static char *txt[SLEN];
static int sp=0;
int ErrCode;
char *ErrMessage=NULL;
void (*outrtn)()=NULL;
void *outarg;
void ErrTxt(char *text, int systemError)
{
if (systemError) { sp=0; ErrCode=errno; ErrMessage=strerror(errno); }
if (sp<SLEN) {
txt[sp++]=text;
}
}
void ErrMsg(char *msg)
{
ErrCode=-1;
ErrMessage=msg; sp=0;
}
void ErrCod(int code)
{
ErrCode=code;
ErrMessage=strerror(code); sp=0;
}
void ErrOutFil(void *arg, char *text) {
fprintf((FILE *)arg, "%s\n", text);
}
void ErrShow(char *text)
{
int i, l;
char buf[256];
if (outrtn==NULL) {
outrtn=ErrOutFil;
outarg=stdout;
}
l=strlen(text)+strlen(ErrMessage)+6;
assert(l<256);
sprintf(buf, "--- %s: %s", text, ErrMessage);
for (i=0;i<sp;i++) {
if (txt[i][0]==':') {
l+=strlen(txt[i]);
assert(l<256);
strcat(buf, &(txt[i][1]));
} else {
outrtn(outarg, buf);
l=strlen(txt[i]);
assert(l<256);
strcpy(buf, txt[i]);
}
}
outrtn(outarg, buf);
outrtn(outarg, "");
}
void ErrShort(char *msg) {
if (outrtn==NULL) {
outrtn=ErrOutFil;
outarg=stdout;
}
outrtn(outarg, msg);
}
void ErrSetOutRtn(void (*rtn)(), void *arg) {
outrtn=rtn;
outarg=arg;
}
void ErrSetOutFile(FILE *arg) {
outrtn=ErrOutFil;
outarg=arg;
}
void ERR_EXIT(char *text) {
ErrShow(text); exit(1);
}
/* FORTRAN wrappers */
#ifdef F_CHAR
/* compile only when fortran c interface stuff is defined */
#ifdef __VMS
#define err_show_ err_show
#define err_txt_ err_txt
#define err_msg_ err_msg
#define err_set_outrtn_ err_set_outrtn
#define err_short_ err_short
#endif
void err_show_(F_CHAR(text), int text_len) {
char buf[256];
STR_TO_C(buf, text);
ErrShow(buf);
}
void err_txt_(F_CHAR(text), int text_len) {
char buf[256];
STR_TO_C(buf, text);
ErrTxt(buf,0);
}
void err_msg_(F_CHAR(text), int text_len) {
char buf[256];
STR_TO_C(buf, text);
ErrMsg(buf);
}
void err_set_outrtn_(void (*rtn)(), void *arg) {
ErrSetOutRtn(rtn, arg);
}
void err_short_(void) {
ErrShort(ErrMessage);
}
#endif

85
tecs/err_handling.h
View File

@ -1,85 +0,0 @@
#ifndef _ERR_HANDLING_H_
#define _ERR_HANDLING_H_
#include <stdio.h>
#include <sys/errno.h>
/* ErrHDL Error handling utilities
-------------------------------
Makes code more readable by hiding annoying error condition checks.
Macros and routines:
Spelling in uppercase indicates, that it the program flow
may be modified (jump to OnError label or program exit).
ERR_x
Usage Error condition Error message taken from
-----------------------------------------------------------------------------------------
ERR_SI(res=routine1(...)) res<0 errno
ERR_SP(ptr=routine2(...)) ptr==NULL errno
ERR_I(res=routine3(...)) res<0 stored by routine3 using errhdl mechanism
ERR_P(ptr=routine4(...)) ptr==NULL stored by routine4 using errhdl mechanism
The result assignment "res=" or "ptr=" is optional.
Description:
The routine routineX is called.
If the result indicates an error, the source text is saved and the
program continues at the OnError label.
The error message and the source code of the calling instructions is
saved for a later call to ErrShow or ErrExit.
ERR_EXIT("program_name")
Show error and exit program.
ERR_MSG("message")
Signals an error condition. If "message" is replaced by a variable,
take care that it is not modified until ErrShow is called.
ERR_COD(cod)
Signals an error condition as code from errno.h
ErrShow("program_name")
Show actual error message with traceback information to stdout
or a file fil
Global Variables (read only)
int ErrCode
actual error message code
= errno for system errors or
= -1 for custom errors signaled by ERRMSG
char *ErrMessage
actual error message
*/
#define ERR_SI(R) { if(0>(R)) { ErrTxt(#R,1); goto OnError; }; }
#define ERR_SP(R) { if(NULL==(R)) { ErrTxt(#R,1); goto OnError; }; }
#define ERR_I(R) { if(0>(R)) { ErrTxt(#R,0); goto OnError; }; }
#define ERR_P(R) { if(NULL==(R)) { ErrTxt(#R,0); goto OnError; }; }
#define ERR_MSG(R) { ErrMsg(R); goto OnError; }
#define ERR_COD(R) { ErrCod(R); goto OnError; }
void ErrTxt(char *text, int systemError);
void ErrMsg(char *msg);
void ErrCod(int code);
void ErrShow(char *text); /* write out error message with stack info */
void ErrShort(char *msg); /* write out short error message */
void ERR_EXIT(char *text);
void ErrSetOutRtn(void (*rtn)(), void *arg);
void ErrSetOutFile(FILE *file);
extern int ErrCode;
extern char *ErrMessage;
#endif /* _ERR_HANDLING_H_ */

2
tecs/instr_hosts.c
View File

@ -68,6 +68,8 @@ int InstrHost(char *input, char *instr, char *host, char *user, char *pcod
#ifdef __VMS
#define instr_host_ instr_host
#elif defined __linux
#define instr_host_ instr_host__
#endif
int instr_host_(F_CHAR(input), F_CHAR(instr), F_CHAR(host), F_CHAR(user), F_CHAR(pcod)

8
tecs/myc_err.c
View File

@ -110,6 +110,14 @@ void ERR_EXIT(char *text) {
#define err_msg_ err_msg
#define err_set_outrtn_ err_set_outrtn
#define err_short_ err_short
#elif defined __linux
#define err_show_ err_show__
#define err_txt_ err_txt__
#define err_msg_ err_msg__
#define err_set_outrtn_ err_set_outrtn__
#define err_short_ err_short__
#endif
void err_show_(F_CHAR(text), int text_len) {

2
tecs/sys_aunix.f
View File

@ -171,7 +171,7 @@
9 call sys_free_lun(lun)
return
19 type *,'SYS_SAVE_ENV: can not open tmp. file'
19 print *,'SYS_SAVE_ENV: can not open tmp. file'
goto 9
end

364
tecs/sys_linux.f Normal file
View File

@ -0,0 +1,364 @@
!!------------------------------------------------------------------------------
!! MODULE SYS
!!------------------------------------------------------------------------------
!! 10.9.97 M. Zolliker
!!
!! System dependent subroutines for ALPHA UNIX
!!------------------------------------------------------------------------------
!!
subroutine SYS_GETENV(NAME, VALUE) !!
!! ==================================
!!
!! Get logical name NAME
!! If the logical name is not in any table, VALUE will be blank
implicit none
!! Arguments:
character*(*) NAME !! logical name
character*(*) VALUE !! result
integer l
integer lnblnk
l=lnblnk(name)
call getenv(name(1:l), value)
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_DATE(YEAR, MONTH, DAY) !!
!! -------------------------------------
!!
!! get actual date
!!
integer YEAR, MONTH, DAY !! 4-Digits year, month and day
integer tarray(9)
external time
integer time
call ltime(time(), tarray)
day=tarray(4)
month=tarray(5)+1 ! tarray(5): months since january (0-11)!
year=tarray(6)+1900 ! tarray(6): years since 1900, no y2k problem
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_REMOTE_HOST(STR, TYPE) !!
!!
!! get remote host name/number
!!
!! type: TN telnet, RT: decnet, XW: X-window
!!
character STR*(*), TYPE*(*) !!
character host*128
integer i,j
integer lnblnk
call sys_getenv('HOST', host)
call sys_getenv('DISPLAY', str)
i=index(str,':')
if (i .gt. 1) then
str=str(1:i-1)
type='XW'
else
call sys_getenv('REMOTEHOST', str)
if (str .ne. ' ') then
type='TN'
else
str=host
type='LO'
endif
endif
! add domain to short host names
i=index(str, '.')
j=index(host, '.')
if (j .gt. 0 .and. i .eq. 0) then
i=lnblnk(str)
str(i+1:)=host(j:)
endif
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_TEMP_NAME(NAME, PATH) !!
!! ====================================
!! get a temporary file name
!!
character*(*) NAME !! (in) name
character*(*) PATH !! (out) path
character line*64, pid*5, nam*64
integer i, l
integer getppid
nam='/tmp/.'
nam(7:)=name
call sys_getenv('USER', line)
if (line .eq. ' ') then
call str_trim(line, nam, l)
else
call str_trim(nam, nam, l)
call str_trim(line, nam(1:l)//'_'//line, l)
endif
write(pid,'(i5)') getppid()
i=1
1 if (pid(i:i) .eq. ' ') then
i=i+1
goto 1
endif
path=line(1:l)//'.'//pid(i:5)
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_LOAD_ENV(FILE) !!
!! =============================
!! load environment from temporary file
!!
character*(*) FILE !! filename
character path*128, line*128
integer lun, i, l
integer getppid
call sys_temp_name(file, path)
call sys_get_lun(lun)
open(lun,file=path,status='old',err=9)
5 read(lun,'(q,a)',end=8) l, line
l=min(l,len(line))
i=index(line,'=')
if (i .eq. 0) then
if (l .gt. 0) call sys_setenv(line(1:l), ' ')
elseif (i .gt. 1 .and. i .lt. l) then
call sys_setenv(line(1:i-1),line(i+1:l))
endif
goto 5
8 close(lun)
9 call sys_free_lun(lun)
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_SAVE_ENV(FILE, NAMES, N_NAMES) !!
!! =============================================
!! save environment on temporary file
!!
character*(*) FILE !! filename
integer N_NAMES !! number of names
character*(*) NAMES(N_NAMES) !! names of variables to save
character path*128, line*128
integer lun, i, j, l
call sys_temp_name(file, path)
call sys_get_lun(lun)
open(lun,file=path,status='unknown',err=19)
do i=1,n_names
call sys_getenv(names(i), line)
call str_trim(names(i),names(i), j)
call str_trim(line,line, l)
write(lun,'(3a)') names(i)(1:j),'=',line(1:l)
enddo
close(lun)
9 call sys_free_lun(lun)
return
19 print *,'SYS_SAVE_ENV: can not open tmp. file'
goto 9
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_WAIT(SECONDS) !!
!! ============================
!! wait for SECONDS
real SECONDS !! resolution should be better than 0.1 sec.
real tim, del
tim=secnds(0.0)
1 del=seconds-secnds(tim)
if (del .ge. 0.999) then
call sleep(int(del))
goto 1
endif
if (del .gt. 0) then
call usleep(int(del*1E6))
goto 1
endif
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_GET_LUN(LUN) !!
!!
!! allocate logical unit number
integer LUN !! out
logical*1 act(50:100)/51*.false./
save act
integer l
l=50
do while (l .lt. 99 .and. act(l))
l=l+1
enddo
if (l .eq. 100) stop 'SYS_GET_LUN: no more luns available'
lun=l
act(l)=.true.
return
!!
entry SYS_FREE_LUN(LUN) !!
!!
!! deallocate logical unit number
if (act(lun)) then
act(lun)=.false.
else
stop 'SYS_FREE_LUN: lun already free'
endif
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_RENAME_FILE(OLD, NEW) !!
!! ====================================
!!
character OLD*(*), NEW*(*) !! (in) old, new filename
call rename(OLD, NEW)
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_DELETE_FILE(NAME) !!
!! ================================
!!
character NAME*(*) !! (in) filename
call unlink(NAME)
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_HOME(HOME) !!
!! =========================
!!
!! get home directory (+ dot)
character HOME*(*) !! (out) filename
integer l
integer lnblnk
call sys_getenv('HOME',home)
l=lnblnk(home)
if (l .lt. len(home)-1) then
if (home(l:l) .ne. '/') then
home(l+1:l+1)='/'
l=l+1
endif
home(l+1:l+1)='.'
l=l+1
endif
end
!!------------------------------------------------------------------------------
!!
subroutine SYS_CHECK_SYSTEM(CODE) !!
!! =================================
!!
character CODE*(*) !!
code='ALPHA_UNIX' !!
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_GET_CMDPAR(STR, L) !!
!! ---------------------------------
!!
character*(*) STR !!
integer L !!
integer i
integer lnblnk, iargc
l=0
str=' '
do i=1,iargc()
if (l .lt. len(str)) then
call getarg(i, str(l+1:))
l=lnblnk(str)
l=l+1
endif
enddo
if (l .gt. 0) then
if (str(1:l) .eq. ' ') l=0
endif
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_GET_KEY(KEY, TMO) !!
!!
!! read for keyboard with timeout, without echo
!!
character KEY*1 !!
integer TMO !! timeout in seconds (<100)
character esc*1, csi*1, ss3*1
esc=char(27)
csi=char(155)
ss3=char(143)
call sys_get_raw_key(key, tmo)
1 if (key .eq. esc) then
call sys_get_raw_key(key, tmo)
if (key .eq. 'O') then
key=ss3
goto 1
elseif (key .eq. '[') then
key=csi
goto 1
endif
elseif (key .eq. csi) then
call sys_get_raw_key(key, tmo)
do while (key .ge. '0' .and. key .le. '9')
call sys_get_raw_key(key, tmo)
enddo
key=' '
elseif (key .eq. ss3) then
call sys_get_raw_key(key, tmo)
if (key .eq. 'm') then
key='-'
elseif (key .eq. 'l') then
key='+'
elseif (key .eq. 'n') then
key='.'
elseif (key .eq. 'M') then
key=char(13)
elseif (key .eq. 'S') then
key='*'
elseif (key .eq. 'R') then
key='/'
elseif (key .eq. 'Q') then
key='='
else
key=' '
endif
endif
end

200
tecs/sys_linux_c.c Normal file
View File

@ -0,0 +1,200 @@
#include <termios.h>
#include <sys/time.h>
#include <assert.h>
#include <unistd.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <setjmp.h>
#include <signal.h>
#include <limits.h>
static char *last_line = NULL;
int lnblnk_(char *c, int c_len);
char *readline(char *prompt);
void add_history(char *line_read);
void sys_rd_line__(char *cmd, int *retlen, char *prompt, int clen, int plen)
{
char *line_read, p[64];
assert(plen < sizeof(p));
strncpy(p,prompt,plen); p[plen] = '\0';
if (last_line == NULL) { last_line =malloc(1); last_line[0] = '\0';};
line_read = readline(p);
if (line_read)
{
if (*line_read && strcmp(last_line, line_read)!=0)
add_history (line_read);
free (last_line);
strncpy(cmd, line_read, clen);
*retlen=strlen(line_read);
last_line = line_read;
if (*retlen>clen) *retlen=clen;
} else {
*retlen=-1;
}
}
void intcatch(int sig)
{ printf("\nuse quit (normally ctrl-\\) to interrupt\n");
}
int called=0; /* env is valid only if called==1 */
jmp_buf env;
void (*inthdl)(int sig);
void (*errhdl)(void);
void sighdl(int sig)
{ if (called) longjmp(env,sig);
}
void sys_err_hdl__(void errhdl0())
{ errhdl=errhdl0; }
void sys_int_hdl__(void inthdl0(int sig))
{ inthdl=inthdl0; }
void sys_try__(void proc())
{ int sig, status;
void (*sgh[32]) (int);
assert(!called); /* nested calls not allowed */
called=1;
sgh[SIGFPE] =signal(SIGFPE, sighdl);
sgh[SIGINT] =signal(SIGINT, *inthdl);
status=setjmp(env);
if (status==0) /* first return of setjmp */
{ proc(); }
else
{ (*errhdl)(); };
signal(SIGFPE, sgh[SIGFPE]);
signal(SIGINT, intcatch);
called=0;
}
void sys_abort__()
{ if (called) longjmp(env,-2);
}
void sys_exit_hdl__(void hdl())
{ int res;
res=atexit(hdl);
}
struct termios atts;
void sys_get_raw_key__(char *key, int *tmo, int k_len)
{
struct termios attr;
int ires, ntmo, chr;
ires=tcgetattr(STDIN_FILENO,&attr);
atts=attr; /* save term. attr. */
if (ires!=0) {perror("***\n");}
attr.c_lflag &= ~(ICANON) & ~(ECHO); /* canonical mode off, echo off */
attr.c_cc[VMIN]=0;
ires= tcsetattr(STDIN_FILENO,TCSANOW,&attr);
if (ires!=0) {perror("***\n");}
/*
ires=fflush(stdin);
ires=fflush(stderr);
*/
ntmo=*tmo*100;
chr=fgetc(stdin);
if (chr==EOF) {
while ((chr==EOF) & (ntmo>0)) {
usleep(10000); /* wait 10 ms */
chr=fgetc(stdin);
ntmo--;
}
}
if (chr==EOF) chr=0;
*key=chr;
ires=tcsetattr(STDIN_FILENO,TCSANOW,&atts); /* restore term. attributes */
if (ires!=0) {perror("***\n");};
}
void usleep_(int *usec) { usleep(*usec); }
int getppid_(void) { return getppid(); }
int sys_setenv__(ename,evalue,ilen1,ilen2)
char *ename, *evalue;
int ilen1, ilen2;
{
int i1, i2, ow, rc;
char *p1, *p2;
i1 = lnblnk_(ename,ilen1);
i2 = lnblnk_(evalue,ilen2);
p1 = malloc((unsigned) i1+1); if( p1 == NULL ) return (-1);
p2 = malloc((unsigned) i2+1); if( p2 == NULL ) { free(p1); return (-1); }
strncpy(p1,ename,i1); p1[i1] = '\0';
strncpy(p2,evalue,i2); p2[i2] = '\0';
ow = 1;
rc = setenv(p1, p2, ow);
free(p1); free(p2);
return(rc);
}
void sys_rd_tmo__(char *prompt, char *result, int *reslen, int p_len, int r_len)
{
struct termios atts;
struct termios attr;
int ires, i, ntmo, chr;
ires=tcgetattr(STDIN_FILENO,&attr);
atts=attr; /* save term. attr. */
if (ires!=0) {perror("***\n");}
attr.c_lflag &= ~(ICANON) & ~(ECHO); /* canonical mode off, echo off */
attr.c_cc[VMIN]=0;
ires= tcsetattr(STDIN_FILENO,TCSANOW,&attr);
if (ires!=0) {perror("***\n");}
do { chr=fgetc(stdin); } while (chr!=EOF);
for (i=0; i<p_len; i++)
{ fputc(prompt[i], stderr);
};
ires=fflush(stdin);
ires=fflush(stderr);
*reslen=0;
if (prompt[0]=='\0') { ntmo=10; }
else { ntmo=200; }; /* wait 2 sec. for the first char */
while (*reslen<r_len)
{ chr=fgetc(stdin);
if (chr==EOF)
{ while ((chr==EOF) & (ntmo>0))
{ usleep(10000); /* wait 10 ms */
chr=fgetc(stdin);
ntmo--;
};
if (chr==EOF) break;
if (chr==10) {ntmo=10;} else {ntmo=100;}; /* wait 0.1 sec after LF, 1 sec else */
};
result[(*reslen)++]=(char)chr;
if (chr==24) {(*reslen)=0;}; /* ctrl-X purges buffer */
};
if (result[(*reslen)-1]=10) {(*reslen)--;}; /* strip trailing LF */
ires=tcsetattr(STDIN_FILENO,TCSANOW,&atts); /* restore term. attributes */
if (ires!=0) {perror("***\n");};
}

16
tecs/tecs_cli.c
View File

@ -123,6 +123,22 @@ void TeccClose(pTecsClient conn) {
#define tecs_date_ tecs_date
#define tecs_time_ tecs_time
#define tecs_rights_ tecs_rights
#elif defined __linux
#define tecs_get_par_ tecs_get_par__
#define tecs_get_mult_ tecs_get_mult__
#define tecs_set_par_ tecs_set_par__
#define tecs_init_ tecs_init__
#define tecs_get3_ tecs_get3__
#define tecs_get_ tecs_get__
#define tecs_set_ tecs_set__
#define tecs_is_open_ tecs_is_open__
#define tecs_close_ tecs_close__
#define tecs_quit_server_ tecs_quit_server__
#define tecs_watch_log_ tecs_watch_log__
#define tecs_get_data_ tecs_get_data__
#define tecs_date_ tecs_date__
#define tecs_time_ tecs_time__
#define tecs_rights_ tecs_rights__
#endif
static pTecsClient conn=NULL;

2
tecs/tecs_client.f
View File

@ -29,7 +29,7 @@
if (line(1:l) .eq. 'off' .or. line(1:l) .eq. 'OFF') then
call tecs_open(0, ' ', iret)
if (iret .lt. 0) goto 91
iret=tecs_quit_server(0)
iret=tecs_quit_server(0)
if (iret .lt. 0) goto 91
goto 99
endif

14
tecs/tecs_for.f
View File

@ -121,7 +121,7 @@ c if INIT exists, read it to get the port number and the start command
startcmd=' '
open (lun, file=init, status='old', readonly, iostat=ios)
open (lun, file=init, status='old', iostat=ios)
if (ios .eq. 0) read (lun, *, iostat=ios) port
if (ios .eq. 0) read (lun, *, iostat=ios) ! skip options line
if (ios .eq. 0) read (lun, '(a)', iostat=ios) startcmd
@ -137,7 +137,8 @@ c if INIT exists, read it to get the port number and the start command
endif
end
SUBROUTINE TECS_GET_T (IOLUN, TEMP, IRET) !!
SUBROUTINE TECS_GET_T (IOLUN, TEMP, IRET) !!
!! =========================================
!!
!! Get temperatures and wait if TECS is configuring
@ -175,7 +176,8 @@ c------------------------------------------------------------------------------
temp(4)=0.0 ! no auxilliary sensor
end
subroutine TECS_WRITE_ERROR(IOLUN) !!
subroutine TECS_WRITE_ERROR(IOLUN) !!
!! ==================================
!!
!! write out error message of last error and stack info
@ -191,7 +193,8 @@ c------------------------------------------------------------------------------
end
subroutine TECS_WRITE_MSG(IOLUN) !!
subroutine TECS_WRITE_MSG(IOLUN) !!
!! ================================
!!
!! write out error message of last error without stack info
@ -207,7 +210,8 @@ c------------------------------------------------------------------------------
end
SUBROUTINE TECS_ERR_ROUTINE (LUN, TEXT)
SUBROUTINE TECS_ERR_ROUTINE (LUN, TEXT)
! =======================================
!
! routine called from C

6
tecs/tecs_plot.for Normal file
View File

@ -0,0 +1,6 @@
subroutine tecs_plot(str)
character str*(*)
print *
& ,'give me Fortran 90 on this machine, I give you graphics'
end