gw18%prism@gatech.edu (Williams, Greg) (02/02/90)
I am having a strange error occur on some f77 and C code on a SPARCstation
1. The error I get is:
signal SEGV (segmentation violation) in do_fio at 0x3d44
do_fio+0xa0: ld [%i5], %o1
This error doesn't occur with any regularity. It will work for about 100
times and then break, and then maybe work for another 20 and break. It
breaks often enough that I need to fix the error.
This error occurs only on the SPARCstation 1. I tried this same code on
an SGI 220s with no problems. What I'm thinking is that it may be a bug
in do_fio or somewhere else in Sun's code. Can anyone confirm this for
me? If so, what can I do to fix it? If its not Sun's fault, then what
needs to be changed to fix it? I'd appreciate any and all help.
(Please no flames about the style because I didn't write it... :-) )
--------------f77 code begins here-------------------------------
program chartest
integer ians, num_chars
character*80 myname
logical test
1000 continue
ians = itdef ('Do you want this?','NO^YES')
print *,ians
goto 1000
end
c-----------------------------------------------
c***********************************************************************
c*
c *
c I T D E F *
c *
c***********************************************************************
c*
c *
c *
c ROUTINE TO RETURN AN INTEGER ANSWER CORRESPONDING TO THE *
c SEQUENTIAL ANSWER IN THE LIST STRING. PRSTRING IS A PROMPT *
c STRING SENT TO THE TERMINAL. STRING IS A LIST OF ALLOWABLE *
c RESPONSES, EACH FOLLOWED BY A '^'. THE FIRST RESPONSE IN *
c STRING IS SET UP A DEFAULT VALUE. *
c *
c EXAMPLE: *
c IANS = ITDEF ('PICK INSTRUCTIONAL DEPARTMENT ', *
c & 'ICS^EE^GEOS^ME^CE^ARCH^') *
c *
c THIS WILL PUT FOLLOWING ON TERMINAL: *
c PICK INSTRUCTIONAL DEPARTMENT <I,E,G,M,C,A> ? _ *
c *
c IF USER TYPES 'G', THE LINE WILL APPEAR AS: *
c PICK INSTRUCTIONAL DEPARTMENT <I,E,G,M,C,A> ? GEOS_ *
c IF USER NOW PRESSES 'DELETE' AND THEN 'A', HE WILL GET *
c PICK INSTRUCTIONAL DEPARTMENT <I,E,G,M,C,A> ? ARCH_ *
c IF HE NOW HITS 'RETURN', CURSOR WILL GO TO NEXT LINE AND *
c ITDEF AND IANS WILL TAKE THE VALUE 6 *
c *
c***********************************************************************
c *
integer function itdef(prstring, string)
integer yes, place(26), nques, icount, i, itot
character prstring*(*), string*(*)
character bs*1, cntl_c*1, cntl_y*1, del*1, cr*1
character ans*1, getchar*1, first*1
character answer*40
character crlf*2
character ischar*26
bs = char(8)
cntl_y = char(25)
cntl_c = char(3)
del = char(127)
cr = char(10)
crlf(1:1) = char(13)
c
crlf(2:2) = char(10)
icount = len(string)
itot = 1
nques = 1
10 if (itot .gt. icount) goto 20
first = string(itot:itot)
if (lge(first,'a') .and. lle(first,'z')) first = char(ichar(first)
& - 32)
ischar(nques:nques) = first
place(nques) = itot
15 itot = itot + 1
if ((string(itot:itot) .ne. '^') .and. (itot .le. icount)) goto 15
itot = itot + 1
nques = nques + 1
c
goto 10
20 place(nques) = itot
nques = nques - 1
if (nques .gt. 26) then
write(unit=*, fmt=*)
&' MORE THAN 26 ANSWERS IN CALL TO ITDEF -- ABORTING.'
itdef = 1
return
c
end if
call prompt(prstring)
call prompt(' <')
do 40 i = 1, nques
call prompt(ischar(i:i))
40 if (i .ne. nques) call prompt(',')
call prompt('> [')
call prompt(ischar(1:1))
call prompt(string(2:place(2) - 2))
c
call prompt('] ? ')
45 ans = getchar()
if ((ans .eq. cntl_y) .or. (ans .eq. cntl_c)) call quit
if (lge(ans,'a') .and. lle(ans,'z')) ans = char(ichar(ans) - 32)
if (ans .eq. cr) then
itdef = 1
call prompt(ischar(1:1))
call prompt(string(2:place(2) - 2))
call prompt(crlf)
return
c
end if
do 50 ipt = 1, nques
yes = ipt
c
c RETURN IN GETCHAR IF AN NON-ANSWER CHARACTER WAS ENTERED
50 if (ans .eq. ischar(yes:yes)) goto 51
c
goto 45
51 call prompt(ischar(yes:yes))
call prompt(string(place(yes) + 1:place(yes + 1) - 2))
55 ans = getchar()
if ((ans .eq. cntl_y) .or. (ans .eq. cntl_c)) call quit
c ERASE WRONG ANSWER AND GET NEXT ANSWER
if ((ans .eq. bs) .or. (ans .eq. del)) then
do 60 i = place(yes), place(yes + 1) - 2
60 call prompt(bs)
call eralin
c
goto 45
c IF NOT CARRIAGE RETURN, GO BACK AND GET A LEGAL CHARACTER
else if (ans .ne. cr) then
goto 55
else
call prompt(crlf)
itdef = yes
c
end if
return
end
c-----------------------------------------------------------
subroutine prompt(pstring)
character pstring*(*)
nchars = len(pstring)
if (nchars .gt. 0) then
write(unit=*, fmt=100) pstring(1:nchars)
c 100 format(1h+,a<nchars>,$)
100 format(a<nchars>,$)
end if
return
end
c-----------------------------------------------------------------
c***********************************************************************
c*
c *
c E R A L I N *
c *
c***********************************************************************
c*
c *
c *
c ROUTINE TO ERASE CURRENT CURSOR LINE ON THE CRT FROM CURSOR *
c POSITION TO EOL. LEAVES CURSOR WHERE IT STARTED. *
c *
c***********************************************************************
c*
c *
subroutine eralin()
character clline*3
clline(1:1) = char(27)
c clline(2:4) = '[0K'
clline(2:3) = '[K'
write(unit=6, fmt=15) clline
c 15 format(1h+,a4,$)
15 format(a3,$)
return
end
c---------------------------------------------------------
cCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
c
c
c THIS SUBROUTINE IS USED TO TERMINATE A FORTRAN PROGRAM
c GRACEFULLY. NORMALLY, WHEN YOU EXIT A FORTRAN PROGRAM, EVEN
c DELIBERATELY, THE OPERATING SYSTEM WOULD PRINT OUT ' PROGRAM STOPPED
c AT SUCH AND SUCH.... THIS ROUTINE AVOIDS SUCH MESSY TERMINATING
c MESSAGES.
c
cCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
c
subroutine quit()
call exit
return
end
subroutine exit()
stop ' '
end
-------------------f77 code ends here-----------------------
-------------------C code begins here-----------------------
#include <termio.h>
#include <stdio.h>
#include <errno.h>
getchar_ (retval_ptr, retval_len)
char *retval_ptr;
int retval_len;
{
struct termio save,term;
char in;
fflush (stdout);
fflush(stdin);
if (ioctl (0,TCGETA, &term) == -1) {
perror();
fprintf (stderr, "standard input not a tty\n");
exit(1);
}
save = term;
term.c_lflag &= ~ICANON;
term.c_lflag &= ~ECHO;
term.c_cc[VMIN] = 1;
term.c_cc[VTIME] = 0;
ioctl (0, TCSETA, &term);
read (0, &in, 1);
*retval_ptr = in;
retval_len = 1;
ioctl (0, TCSETA, &save);
}
-------------------C code ends here---------------------------
Greg Williams
Georgia Institute of Technology, Atlanta Georgia, 30332
uucp: ...!{decvax,hplabs,ncar,purdue,rutgers}!gatech!prism!gw18
Internet: gw18@prism.gatech.edu