diff --git a/tecs/err_handling.c b/tecs/err_handling.c deleted file mode 100644 index 0b79ac79..00000000 --- a/tecs/err_handling.c +++ /dev/null @@ -1,136 +0,0 @@ -#include -#include -#include - -#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 -#include - -/* 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_ */ diff --git a/tecs/instr_hosts.c b/tecs/instr_hosts.c index 66a457af..ecbdd5ab 100644 --- a/tecs/instr_hosts.c +++ b/tecs/instr_hosts.c @@ -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) diff --git a/tecs/myc_err.c b/tecs/myc_err.c index ec890c5a..db63fb30 100644 --- a/tecs/myc_err.c +++ b/tecs/myc_err.c @@ -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) { diff --git a/tecs/sys_aunix.f b/tecs/sys_aunix.f index ca4cea7e..97cfbecf 100644 --- a/tecs/sys_aunix.f +++ b/tecs/sys_aunix.f @@ -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 diff --git a/tecs/sys_linux.f b/tecs/sys_linux.f new file mode 100644 index 00000000..ea6b4a1c --- /dev/null +++ b/tecs/sys_linux.f @@ -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 diff --git a/tecs/sys_linux_c.c b/tecs/sys_linux_c.c new file mode 100644 index 00000000..8411c51d --- /dev/null +++ b/tecs/sys_linux_c.c @@ -0,0 +1,200 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +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; i0)) + { 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");}; +} diff --git a/tecs/tecs_cli.c b/tecs/tecs_cli.c index f1690941..a2b87ff7 100644 --- a/tecs/tecs_cli.c +++ b/tecs/tecs_cli.c @@ -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; diff --git a/tecs/tecs_client.f b/tecs/tecs_client.f index a8d995c4..75bc4738 100644 --- a/tecs/tecs_client.f +++ b/tecs/tecs_client.f @@ -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 diff --git a/tecs/tecs_for.f b/tecs/tecs_for.f index 9d2fa1e3..3d073c9d 100644 --- a/tecs/tecs_for.f +++ b/tecs/tecs_for.f @@ -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 diff --git a/tecs/tecs_plot.for b/tecs/tecs_plot.for new file mode 100644 index 00000000..ee91e32d --- /dev/null +++ b/tecs/tecs_plot.for @@ -0,0 +1,6 @@ + subroutine tecs_plot(str) + character str*(*) + + print * + & ,'give me Fortran 90 on this machine, I give you graphics' + end