Trailing-Edge
-
PDP-10 Archives
-
BB-K840A-BM_1981
-
sources/ratmig.for
There are 2 other files named ratmig.for in the archive. Click here to see a list.
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C ratmig -- I/O for RATFOR preprocessor including migration from RT-11
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C copyright notice
C
C
C C O P Y R I G H T
C
C
C Copyright (C) 1980 by
C Digital Equipment Corporation, Maynard, Mass.
C
C
C This software is furnished under a license and may be used and
C copied only in accordance with the terms of such license and
C with the inclusion of the above copyright notice. This
C software or any other copies thereof may not be provided or
C otherwise made available to any other person. No title to and
C ownership of the software is hereby transferred.
C
C The information in this software is subject to change without
C notice and should not be construed as a commitment by Digital
C Equipment Corporation.
C
C DIGITAL assumes no responsibility for the use or reliability
C of its software on equipment that is not supplied by DIGITAL.
C
C ========== Ratfor character definitions ==========
C 9-FEB-79
C 12-MAY-80
C ampersand
C exclamation mark
C ASCIZ strings as used by SYSLIB
C max element count in packed char array
C input record size
C must be 2 more than MAXRECORD
C alternative to YES, NO
C a linefeed
C for OPENF calls
C "
C "
C "
C char i/o format: "r1" for TOPS-20; "a1" otherwise
C quoted string version of above
C first char for single space with LIST carriagecontrol:
C ' ' for RSTS, nothing for VMS
C ascii numeric value corresponding to LISTSS, above
C if "#", omit packed string code for this machine
C 5 for TOPS-20, 1 otherwise
C if "#", omit TOPS20 code
C scopy -- copy a character string to its full length
integer function scopy ( in , out )
integer in ( 1 ) , out ( 1 )
continue
i = 1
23000 if(.not.(in(i).ne.0))goto 23002
out ( i ) = in ( i )
23001 i=i+1
goto 23000
23002 continue
out ( i ) = 0
C terminate output string
scopy = i - 1
return
end
C of scopy
C scopyl -- copy a character string given a maximum length
integer function scopyl ( in , out , maxlen )
integer in ( 1 ) , out ( 1 )
integer maxlen
continue
i = 1
23003 if(.not.(i.le.maxlen.and.in(i).ne.0))goto 23005
out ( i ) = in ( i )
23004 i=i+1
goto 23003
23005 continue
out ( i ) = 0
scopyl = i - 1
return
end
C of scopyl
C makeuc -- translate alphabetics to upper case
integer function makeuc ( str )
integer str ( 1 ) , upper
continue
i = 1
23006 if(.not.(str(i).ne.0))goto 23008
str ( i ) = upper ( str ( i ) )
23007 i=i+1
goto 23006
23008 continue
makeuc = i - 1
return
end
C of makeuc
C upper -- translate a character to upper case
integer function upper ( c )
integer c
upper = c .and. " 177
if(.not.( upper .lt. 97 ))goto 23009
return
23009 continue
if(.not.( upper .gt. 122 ))goto 23011
return
23011 continue
upper = upper .and. ( .not. " 40 )
return
end
C makelc -- translate alphabetics to lower case
integer function makelc ( str )
integer str ( 1 ) , lower
continue
i = 1
23013 if(.not.(str(i).ne.0))goto 23015
str ( i ) = lower ( str ( i ) )
23014 i=i+1
goto 23013
23015 continue
makelc = i - 1
return
end
C of makelc
C lower -- translate a character to lower case
integer function lower ( c )
integer c
lower = c .and. " 177
if(.not.( lower .lt. 65 ))goto 23016
return
23016 continue
if(.not.( lower .gt. 90 ))goto 23018
return
23018 continue
lower = lower .or. " 40
return
end
C cvt -- remove blanks and control chars from string
integer function cvt ( str )
integer str ( 1 ) , chr
integer in , out
out = 1
continue
in = 1
23020 continue
chr = str ( in )
if(.not.( chr .eq. 0 ))goto 23023
goto 23022
23023 continue
if(.not.( chr .gt. 32 ))goto 23025
str ( out ) = chr
out = out + 1
23025 continue
23021 in=in+1
goto 23020
23022 continue
str ( out ) = 0
cvt = out - 1
return
end
C of cvt
C trim -- remove trailing blanks and h.o. padding from string
integer function trim ( buf )
C returns length of string
implicit integer ( a - z )
integer buf ( 1 )
continue
i = 1
23027 continue
buf ( i ) = buf ( i ) .and. " 177
C remove h.o. bit(s)
if(.not.( buf ( i ) .eq. 0 ))goto 23030
goto 23029
23030 continue
23028 i=i+1
goto 23027
23029 continue
continue
j = i - 1
23032 if(.not.(j.ge.1.and.buf(j).eq.32))goto 23034
C locate last non-blank character
continue
23033 j=j-1
goto 23032
23034 continue
buf ( j + 1 ) = 0
C new terminator location
trim = j
return
end
C lpad -- pad out a string to a given length by adding padding on the left
integer function lpad ( str , padc , len )
C returns length of result
implicit integer ( a - z )
integer str ( 1 ) , padc
integer len
integer dif
lpad = length ( str )
dif = len - lpad
if(.not.( dif .gt. 0 ))goto 23035
do 23037 i = lpad + 1 , 1 , - 1
C "lpad+1" includes EOS
str ( i + dif ) = str ( i )
23037 continue
23038 continue
C move stuff over by difference
do 23039 i = 1 , dif
str ( i ) = padc
23039 continue
23040 continue
C add left padding
lpad = len
C returns "len" unless original
C string longer than "len"
23035 continue
return
end
C rpad -- pad out a string to a given length by adding padding on the right
integer function rpad ( str , padc , len )
C returns length of result
implicit integer ( a - z )
integer str ( 1 ) , padc
integer len
rpad = length ( str )
if(.not.( rpad .ge. len ))goto 23041
return
C already long enough, just return length
23041 continue
do 23043 j = rpad + 1 , len
str ( j ) = padc
C else add padding character as required
23043 continue
23044 continue
rpad = len
str ( len + 1 ) = 0
C terminate
return
end
C length -- length of an ASCIZ string
integer function length ( str )
integer str ( 1 )
continue
i = 1
23045 if(.not.(str(i).ne.0))goto 23047
23046 i=i+1
goto 23045
23047 continue
length = i - 1
return
end
C of length
C iscomp -- compare two character strings
integer function iscomp ( str1 , str2 )
integer str1 ( 1 ) , str2 ( 1 )
continue
i = 1
23048 continue
iscomp = str1 ( i ) - str2 ( i )
if(.not.( iscomp .ne. 0 ))goto 23051
goto 23050
23051 continue
if(.not.( str1 ( i ) .eq. 0 ))goto 23053
goto 23050
23053 continue
23049 i=i+1
goto 23048
23050 continue
return
end
C of iscomp
C indexx -- find position of pattern in string
integer function indexx ( str , pattrn , start )
integer str ( 1 ) , pattrn ( 1 )
integer start
integer lpat
lpat = length ( pattrn )
continue
i = start
23055 if(.not.(str(i).ne.0))goto 23057
if(.not.( str ( i ) .eq. pattrn ( 1 ) ))goto 23058
continue
j = 2
23060 if(.not.(j.le.lpat.and.str(i+j-1).eq.pattrn(j)))goto 23062
23061 j=j+1
goto 23060
23062 continue
if(.not.( j .gt. lpat ))goto 23063
indexx = i
return
23063 continue
23058 continue
23056 i=i+1
goto 23055
23057 continue
indexx = 0
C failure to find
return
end
C of indexx
C rindex -- find position of pattern in string, searching from end to start
integer function rindex ( str , pattrn , strt )
integer str ( 1 ) , pattrn ( 1 )
integer strt , start
integer lpat
lpat = length ( pattrn )
start = length ( str )
if(.not.( strt .gt. 0 .and. strt .lt. start ))goto 23065
start = strt
C use supplied start if in range, else use end
23065 continue
start = start - lpat + 1
continue
i = start
23067 if(.not.(i.gt.0))goto 23069
if(.not.( str ( i ) .eq. pattrn ( 1 ) ))goto 23070
continue
j = 2
23072 if(.not.(j.le.lpat.and.str(i+j-1).eq.pattrn(j)))goto 23074
23073 j=j+1
goto 23072
23074 continue
if(.not.( j .gt. lpat ))goto 23075
rindex = i
return
23075 continue
23070 continue
23068 i=i-1
goto 23067
23069 continue
rindex = 0
C failure to find
return
end
C of rindex
C getstr -- get a line of input
integer function getstr ( lun , line , lim )
implicit integer ( a - z )
integer lun , lim , length
integer line ( 1 )
length = lim
C in case "q" format not available
if(.not.( lun .le. 0 ))goto 23077
accept 100 , ( line ( i ) , i = 1 , min0 ( length , lim ) )
goto 23078
23077 continue
read ( lun , 100 , err = 200 , end = 300 ) ( line ( i ) , i = 1 ,
*min0 ( length , lim ) )
23078 continue
100 format ( 255 r1 )
getstr = min0 ( length , lim )
line ( getstr + 1 ) = 0
getstr = trim ( line )
return
200 getstr = - 4
return
300 getstr = - 3
C end of file
return
end
C of getstr
C putstr -- put a (possibly packed character) string
integer function putstr ( lun , line , cc )
implicit integer ( a - z )
integer lun , icc
integer line ( 1 ) , cc , ccc
logical ispack
if(.not.( cc .eq. 0 ))goto 23079
icc = 0
goto 23080
23079 continue
icc = 1
23080 continue
if(.not.( lun .le. 0 .and. icc .eq. 0 ))goto 23081
icc = 1
ccc = 32
goto 23082
23081 continue
ccc = cc
23082 continue
if(.not.( .not. ispack ( line ) ))goto 23083
C the following code handles unpacked strings
putstr = length ( line )
if(.not.( lun .le. 0 ))goto 23085
type 100 , ( ccc , i = 1 , icc ) , ( line ( i ) , i = 1 , putstr )
goto 23086
23085 continue
write ( lun , 100 ) ( cc , i = 1 , icc ) , ( line ( i ) , i = 1 ,
*putstr )
23086 continue
100 format ( r1 , 255 r1 )
C the following code handles packed strings
goto 23084
23083 continue
C here we assume a system-dependent packing rate handled by "a" format
C "cc" must still be right-adjusted ascii
putstr = lengp ( line )
if(.not.( lun .le. 0 ))goto 23087
type 200 , ( ccc , i = 1 , icc ) , ( line ( i ) , i = 1 , putstr )
goto 23088
23087 continue
write ( lun , 200 ) ( cc , i = 1 , icc ) , ( line ( i ) , i = 1 ,
*putstr )
23088 continue
200 format ( r1 , 255 a )
23084 continue
return
end
C of putstr
C ptprmt -- put a (possibly packed character) string, with no CR at end
integer function ptprmt ( lun , line , cc )
implicit integer ( a - z )
integer lun , icc
integer line ( 1 ) , cc , ccc
logical ispack
if(.not.( cc .eq. 0 ))goto 23089
icc = 0
goto 23090
23089 continue
icc = 1
23090 continue
if(.not.( lun .le. 0 .and. icc .eq. 0 ))goto 23091
icc = 1
ccc = 32
goto 23092
23091 continue
ccc = cc
23092 continue
if(.not.( .not. ispack ( line ) ))goto 23093
C the following code handles unpacked strings
ptprmt = length ( line )
if(.not.( lun .le. 0 ))goto 23095
type 100 , ( ccc , i = 1 , icc ) , ( line ( i ) , i = 1 , ptprmt )
goto 23096
23095 continue
write ( lun , 100 ) ( cc , i = 1 , icc ) , ( line ( i ) , i = 1 ,
*ptprmt )
23096 continue
100 format ( r1 , $ , 255 ( r1 , $ ) )
C the following code handles packed strings
goto 23094
23093 continue
C here we assume a system-dependent packing rate handled by "a" format
C "cc" must still be right-adjusted ascii
ptprmt = lengp ( line )
if(.not.( lun .le. 0 ))goto 23097
type 200 , ( ccc , i = 1 , icc ) , ( line ( i ) , i = 1 , ptprmt )
goto 23098
23097 continue
write ( lun , 200 ) ( cc , i = 1 , icc ) , ( line ( i ) , i = 1 ,
*ptprmt )
23098 continue
200 format ( r1 , $ , 255 ( a , $ ) )
23094 continue
return
end
C of ptprmt
C ispack -- decide if string is packed characters
logical function ispack ( str )
integer str ( 1 )
C test for content greater than one right-adjusted char
C such a string is assumed to be an unpacked EOS-terminated character array
ispack = ( ( str ( 1 ) .and. ( .not. " 377 ) ) .ne. 0 )
C this will always return "false" on byte systems
return
end
C of ispack
C lengp -- length of a packed string (returns element count, not character count)
integer function lengp ( str )
integer str ( 1 )
C we hope to find a terminating l.o. zero
continue
i = 1
23099 if(.not.(i.le.100))goto 23101
if(.not.( ( str ( i ) .and. " 177 ) .eq. 0 ))goto 23102
goto 23101
23102 continue
23100 i=i+1
goto 23099
23101 continue
if(.not.( str ( i ) .eq. 0 ))goto 23104
lengp = i - 1
goto 23105
23104 continue
lengp = i
C this only works on systems where packed chars are packed from h.o. to l.o.
23105 continue
return
end
C of lengp
C ctoi - convert string at in(i) to integer, increment i
integer function ctoi ( in , i )
integer in ( 1 )
integer indexx
integer c ( 2 )
integer d , i
C string digits "0123456789"
integer digits ( 11 )
data digits / 48 , 49 , 50 , 51 , 52 , 53 , 54 , 55 , 56 , 57 , 0
*/
data c ( 2 ) / 0 /
continue
23106 if(.not.( in ( i ) .eq. 32 .or. in ( i ) .eq. 9 ))goto 23107
i = i + 1
goto 23106
23107 continue
continue
ctoi = 0
23108 if(.not.(in(i).ne.0))goto 23110
c ( 1 ) = in ( i )
C ensure zero-termination
d = indexx ( digits , c , 1 )
if(.not.( d .eq. 0 ))goto 23111
C non-digit
goto 23110
23111 continue
ctoi = 10 * ctoi + d - 1
23109 i=i+1
goto 23108
23110 continue
return
end
C equal - compare str1 to str2; return YES if equal, NO if not
integer function equal ( str1 , str2 )
integer str1 ( 1 ) , str2 ( 1 )
integer i
continue
i = 1
23113 if(.not.(str1(i).eq.str2(i)))goto 23115
if(.not.( str1 ( i ) .eq. 0 ))goto 23116
equal = 1
return
23116 continue
23114 i=i+1
goto 23113
23115 continue
equal = 0
return
end
C matchs - compare str1 to str2; return YES if equal, NO if not
integer function matchs ( str1 , str2 )
integer str1 ( 1 ) , str2 ( 1 )
integer i , upper
continue
i = 1
23118 if(.not.(upper(str1(i)).eq.upper(str2(i))))goto 23120
if(.not.( str1 ( i ) .eq. 0 ))goto 23121
matchs = 1
return
23121 continue
23119 i=i+1
goto 23118
23120 continue
matchs = 0
continue
j = i
23123 if(.not.(str1(j).ne.0))goto 23125
C scan for all-blank trailer
if(.not.( str1 ( j ) .ne. 9 .and. str1 ( j ) .ne. 32 ))goto 23126
return
23126 continue
23124 j=j+1
goto 23123
23125 continue
continue
j = i
23128 if(.not.(str2(j).ne.0))goto 23130
C scan for all-blank trailer
if(.not.( str2 ( j ) .ne. 9 .and. str2 ( j ) .ne. 32 ))goto 23131
return
23131 continue
23129 j=j+1
goto 23128
23130 continue
matchs = 1
return
end
C stemeq - compare master to another string;
C return YES if equal up to length of master, NO if not
C return NO if "tested" string is null
C compare without regard to case of alphabetics
integer function stemeq ( master , tested )
integer master ( 1 ) , tested ( 1 )
integer i , upper
continue
i = 1
23133 if(.not.(upper(master(i)).eq.upper(tested(i))))goto 23135
if(.not.( master ( i ) .eq. 0 ))goto 23136
goto 23135
23136 continue
23134 i=i+1
goto 23133
23135 continue
if(.not.( i .gt. 1 .and. tested ( i ) .eq. 0 ))goto 23138
stemeq = 1
goto 23139
23138 continue
stemeq = 0
23139 continue
return
end
C itoc - convert integer int to char string in str
integer function itoc ( int , str , size )
integer abs , mod
integer d , i , int , intval , j , k , size
integer str ( size )
C string digits "0123456789"
integer digits ( 11 )
data digits / 48 , 49 , 50 , 51 , 52 , 53 , 54 , 55 , 56 , 57 , 0
*/
intval = abs ( int )
str ( 1 ) = 0
i = 1
continue
23140 continue
C generate digits
i = i + 1
d = mod ( intval , 10 )
str ( i ) = digits ( d + 1 )
intval = intval / 10
23141 if(.not.( intval .eq. 0 .or. i .ge. size ))goto 23140
23142 continue
if(.not.( int .lt. 0 .and. i .lt. size ))goto 23143
C then sign
i = i + 1
str ( i ) = 45
23143 continue
itoc = i - 1
continue
j = 1
23145 if(.not.(j.lt.i))goto 23147
C then reverse
k = str ( i )
str ( i ) = str ( j )
str ( j ) = k
i = i - 1
23146 j=j+1
goto 23145
23147 continue
return
end
C ftocg -- convert a real number to a character string, using "g" format
integer function ftocg ( r , str , max0 )
C returns length of "str"
real r
integer str ( 1 )
C must be at least "max+1"
integer max0
integer scopy , type
integer pstr ( 21 )
C "packed" internal character string
encode ( 20 , 100 , pstr ) r
100 format ( g )
C default g size
call unpack ( pstr , str , max0 )
continue
i = 1
23148 if(.not.(i.le.max0.and.str(i).ne.46))goto 23150
C find decimal point
23149 i=i+1
goto 23148
23150 continue
continue
i = i + 1
23151 if(.not.(i.le.max0.and.type(str(i)).eq.2))goto 23153
C find first non-digit
23152 i=i+1
goto 23151
23153 continue
continue
j = i - 1
23154 if(.not.(j.gt.0.and.str(j).eq.48))goto 23156
C find least significant digit
23155 j=j-1
goto 23154
23156 continue
call scopy ( str ( i ) , str ( j + 1 ) )
C remove trailing zeros!
continue
i = 1
23157 if(.not.(i.le.max0.and.str(i).eq.32.and.str(i).ne.0))goto 23159
C find first non-blank
23158 i=i+1
goto 23157
23159 continue
continue
ftocg = scopy ( str ( i ) , str )
23160 if(.not.(str(ftocg).eq.32))goto 23162
str ( ftocg ) = 0
C eliminate the blanks
C the following is validation code that could be removed
23161 ftocg=ftocg-1
goto 23160
23162 continue
i = length ( str )
if(.not.( i .ne. ftocg .or. i .gt. max0 ))goto 23163
stop'RATLIB -- error in FTOCG'
23163 continue
return
end
C strsub -- substitute an argument value for "%%" in a string
integer function strsub ( instr , inouts , arg , type , maxl )
C returns length of new string
integer instr ( 1 ) , inouts ( 1 ) , type
C character/integer/real "arg" -- depending upon "type"
integer maxl
integer scopy , scopyl , length , indexx , itoc , ftocg , splice
integer work ( 31 )
integer pp , sl , l
integer perper(3)
integer errstr(8)
data perper /37,37,0/
data errstr /42,42,69,82,82,42,42,0/
C if "instr" is not a null string, first copy it to "inouts",
C -- else use "inouts" as-is
if(.not.( instr ( 1 ) .ne. 0 ))goto 23165
call scopyl ( instr , inouts , maxl )
23165 continue
pp = indexx ( inouts , perper , 1 )
if(.not.( pp .eq. 0 ))goto 23167
l = length ( inouts )
pp = l + 1
C if no "%%" found, put it at end
goto 23168
23167 continue
i = scopy ( inouts ( pp + 2 ) , inouts ( pp ) )
C remove the "%%"
l = pp + i - 1
23168 continue
if(.not.( type .eq. 0 .or. type .eq. 99 .or. type .eq. 115 ))goto
*23169
C "c"haracter "s"tring
sl = length ( arg )
if(.not.( sl + l .le. maxl ))goto 23171
C see if it fits
strsub = splice ( inouts , arg , pp )
goto 23172
23171 continue
C if it won't fit, copy what will fit up to "work" length
call scopyl ( arg , work , min0 ( 30 , maxl - l ) )
strsub = splice ( inouts , work , pp )
23172 continue
goto 23170
23169 continue
if(.not.( type .eq. 105 ))goto 23173
C "i"nteger
call itoc ( arg , work , 30 )
call scopyl ( work , work , maxl - l )
C truncate it if too big
strsub = splice ( inouts , work , pp )
goto 23174
23173 continue
if(.not.( type .eq. 102 .or. type .eq. 114 ))goto 23175
C "f"loating point or "r"eal
call ftocg ( arg , work , 30 )
call scopyl ( work , work , maxl - l )
C truncate it if too big
strsub = splice ( inouts , work , pp )
goto 23176
23175 continue
C error, unrecognized type
call scopyl ( errstr , work , maxl - l )
strsub = splice ( inouts , work , pp )
C the following is validation code that could be removed
23176 continue
23174 continue
23170 continue
i = length ( inouts )
if(.not.( i .ne. strsub .or. i .gt. maxl ))goto 23177
stop'RATLIB -- error in STRSUB'
23177 continue
return
end
C putdec - put decimal integer n in field width >= w
subroutine putdec ( n , w , fd )
integer chars ( 20 )
integer itoc
integer i , n , nd , w , fd
nd = itoc ( n , chars , 20 )
continue
i = nd + 1
23179 if(.not.(i.le.w))goto 23181
call putch ( 32 , fd )
23180 i=i+1
goto 23179
23181 continue
continue
i = 1
23182 if(.not.(i.le.nd))goto 23184
call putch ( chars ( i ) , fd )
23183 i=i+1
goto 23182
23184 continue
return
end
C splice - splice a string into the middle of another string
integer function splice ( inout , in , pos )
integer inout ( 1 ) , in ( 1 )
integer pos
integer c
integer l1 , l2 , tpos , length
l1 = length ( inout )
l2 = length ( in )
tpos = min0 ( l1 + 1 , max0 ( 1 , pos ) )
C move tail end to make room
continue
i = l1 + l2 + 1
23185 if(.not.(i.ge.tpos+l2))goto 23187
inout ( i ) = inout ( i - l2 )
23186 i=i-1
goto 23185
23187 continue
c = inout ( tpos + l2 )
C save first, it will get clobbered
call scopy ( in , inout ( tpos ) )
C get insert
inout ( tpos + l2 ) = c
C restore it
splice = l1 + l2
C return length
return
end
C strpqt -- strip quotes from a quoted string
integer function strpqt ( str , qt )
implicit integer ( a - z )
integer str ( 1 ) , qt
if(.not.( str ( 1 ) .ne. qt ))goto 23188
strpqt = - 1
return
23188 continue
i = 2
j = 1
continue
23190 continue
if(.not.( str ( i ) .eq. qt ))goto 23193
i = i + 1
23193 continue
str ( j ) = str ( i )
if(.not.( str ( i ) .eq. 0 ))goto 23195
goto 23192
23195 continue
i = i + 1
j = j + 1
23191 goto 23190
23192 continue
strpqt = j - 1
return
end
C of strpqt
C puttyp -- add file type to end of file name if not specified
integer function puttyp ( innam , outnam , type )
C return length of result
integer innam ( 1 ) , outnam ( 1 ) , type ( 1 )
logical indir , typfnd
integer c
integer scopy
indir = . false .
typfnd = . false .
continue
i = 1
23197 if(.not.(innam(i).ne.0))goto 23199
c = innam ( i )
outnam ( i ) = c
C copy over while looking
if(.not.( c .eq. 60 .or. c .eq. 91 ))goto 23200
indir = . true .
goto 23201
23200 continue
if(.not.( c .eq. 62 .or. c .eq. 93 ))goto 23202
indir = . false .
goto 23203
23202 continue
if(.not.( c .eq. 46 .and. .not. indir ))goto 23204
typfnd = . true .
23204 continue
23203 continue
23201 continue
23198 i=i+1
goto 23197
23199 continue
outnam ( i ) = 0
if(.not.( .not. typfnd .and. i .gt. 1 ))goto 23206
l = scopy ( type , outnam ( i ) )
C add type to end if none found
goto 23207
23206 continue
l = 0
23207 continue
puttyp = i - 1 + l
C return the length
return
end
C openio -- open input and output files after obtaining names from user
logical function openio ( in , out )
implicit integer ( a - z )
integer in , out
C lun's
integer buf ( 101 )
logical openf
openio = . false .
type 100
100 format (' file>' , $ )
if(.not.( getstr ( 0 , buf , 100 ) .le. 0 ))goto 23208
return
C error
23208 continue
i = indexx ( buf ,'=' , 2 )
if(.not.( i .ne. 0 ))goto 23210
buf ( i ) = 0
23210 continue
if(.not.( .not. openf ( in , buf ( i + 1 ) , 2 ) ))goto 23212
goto 999
23212 continue
if(.not.( .not. openf ( out , buf , 1 ) ))goto 23214
goto 888
23214 continue
openio = . true .
C good return, both open
return
999 type 200
200 format (' error in opening file:' )
call putstr ( 0 , buf ( i + 1 ) , 32 )
return
888 type 200
call putstr ( 0 , buf , 32 )
return
end
C type - return LETTER, DIGIT or character
C this one works with ascii alphabet
integer function type ( c )
integer c
if(.not.( c .ge. 48 .and. c .le. 57 ))goto 23216
type = 2
goto 23217
23216 continue
if(.not.( c .ge. 97 .and. c .le. 122 ))goto 23218
type = 1
goto 23219
23218 continue
if(.not.( c .ge. 65 .and. c .le. 90 ))goto 23220
type = 1
goto 23221
23220 continue
type = c
23221 continue
23219 continue
23217 continue
return
end
C setup -- issue GIGI terminal setup commands
subroutine setup ( str )
implicit integer ( a - z )
integer str ( 1 ) , esc , bs
logical ispack
data esc , bs / 155 , 92 /
if(.not.( .not. ispack ( str ) ))goto 23222
type 100 , esc , ( str ( i ) , i = 1 , length ( str ) ) , esc , bs
goto 23223
23222 continue
type 200 , esc , ( str ( i ) , i = 1 , lengp ( str ) )
type 300 , esc , bs
23223 continue
100 format ('+' , r1 ,'Pr' , 255 ( r1 , $ ) )
200 format ('+' , r1 ,'Pr' , 255 ( a , $ ) )
300 format ('+' , 2 r1 , $ )
return
end
C escseq -- send an escape sequence
subroutine escseq ( str )
implicit integer ( a - z )
integer str ( 1 ) , esc
logical ispack
data esc / 155 /
if(.not.( .not. ispack ( str ) ))goto 23224
type 100 , esc , ( str ( i ) , i = 1 , length ( str ) )
goto 23225
23224 continue
type 200 , esc , ( str ( i ) , i = 1 , lengp ( str ) )
23225 continue
100 format ('+' , 255 ( r1 , $ ) )
200 format ('+' , 255 ( a , $ ) )
return
end
C pack - convert an unpacked character string to most packed format
integer function p a c k ( from , to )
integer from ( 1 )
integer to ( 32767 )
l = length ( from )
C "from" is in our right adjusted internal form
encode ( l + 1 , 100 , to ) ( from ( i ) , i = 1 , l + 1 )
C carry zero over
100 format ( 255 r1 )
p a c k = l
return
end
C of pack
C unpack - convert a packed character string to internal format
integer function u n p a c k ( from , to , l )
implicit integer ( a - z )
integer from ( 1 ) , to ( 1 )
integer l
C number of characters (or neg to let us determine it)
integer length , lengp
if(.not.( l .lt. 0 ))goto 23226
len = lengp ( from ) * 5
goto 23227
23226 continue
len = l
23227 continue
decode ( len , 100 , from ) ( to ( i ) , i = 1 , len )
100 format ( 255 r1 )
to ( len + 1 ) = 0
C "to" is in internal format
u n p a c k = length ( to )
return
end