Google
 

Trailing-Edge - PDP-10 Archives - BB-K818A-BM_1981 - sources/geio.for
There are no other files named geio.for in the archive.
C  geio -- Graphics Editor I/O (was t20f on TOPS-20)
C RATFOR library
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 local to Graphics Editor
C  Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C operating-system-dependent switches
C  Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
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 	define char byte
C  27+128
C  w(riting) opt(ion)s come groups of 8:
C 	(1) replace(0)/erase(1)/complement(2)/overlay(3)
C 	(2) negative image 0/1
C 	(3) pattern  < 256	bit mask (e.g. 192 = P11000000)
C 		    >= 256	canned pattern * 256 (e.g. 512 = P2)
C 				if value >= 256, low 8 bits are ignored
C 	(4) pattern multiplier, different from 6(?)
C 	(5) shading flag, sim pattern+ >= 10 use char
C 	(6) if shading != 0 this is y reference val
C 	(7) pixel multiplier, 1 <= value <= 10
C 	(8) alternating 0/1
C 	(9) foreground intensity, 0 <= value <= 7
C 	(10) background intensity, 0 <= value <= 7
C 
C   offsets from gwopsp...
C   Inktypes...
C   Inkolors...
C Text options
C 	RSTSONLY	define Maxgels 1000	# due to limited RAM on RSTS
C   drawing primitive gels...
C   attribute/marker/other gels...
C   writing attribute gels : Woptbase + wopindex
C   similarly topts...
C maximum # of characters in a filespec
C maximum # of characters in a command line
C max length of prompt buffer
C max number of characters in file record
C size of record buffers (Fbufsz + 1)
C 	include logdef
C ========================================================================
C ========================================================================
C NOTE - The following definitions are operating-system dependent
C TOPS-20 tty logical unit number
C TOPS-20 input file logical unit #
C TOPS-20 output file logical unit #
C End of operating-system dependent defines
C closef - close a file opened by openf
C  Note:  This routine belongs in the same module as openf
      subroutine closef ( lun )
      integer lun
C logical unit #
      close ( unit = lun )
      end
C clsinp - close the input file
      subroutine clsinp
      call closef ( 20 )
      end
C clsout - close the output file
      subroutine clsout
C cio - COMMON areas for Graphics Editor I/O
      common / cio / ip1 , iplast , optr , putlun , obuf , ibuf
      integer ip1
C subscript of last character fetched from ibuf
      integer iplast
C subscript of last character in ibuf
      integer optr
C subscript of last character stored in obuf
      integer putlun
C logical unit # for putc (either OUTLUN or TTYLUN)
      integer obuf ( 133 )
C buffer for output record (built by putc)
      integer ibuf ( 133 )
C input buffer used by getc
      call flusho
C flush buffer first
      if(.not.( putlun .eq. 21 ))goto 23000
C writing to file?
      call closef ( 21 )
C yes, close the file
      putlun = 5
C back to the tty
23000 continue
      end
C flusho - flush the output buffer maintained by putc
      subroutine flusho
C cio - COMMON areas for Graphics Editor I/O
      common / cio / ip1 , iplast , optr , putlun , obuf , ibuf
      integer ip1
C subscript of last character fetched from ibuf
      integer iplast
C subscript of last character in ibuf
      integer optr
C subscript of last character stored in obuf
      integer putlun
C logical unit # for putc (either OUTLUN or TTYLUN)
      integer obuf ( 133 )
C buffer for output record (built by putc)
      integer ibuf ( 133 )
C input buffer used by getc
C  Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
      common / logcom / logsw
      logical logsw
      integer i , j , strt
C 	LOGSTAR 'flusho>', putlun, optr, OUTLUN, TTYLUN
      if(.not.( optr .gt. 0 ))goto 23002
C something in buffer?
      obuf ( optr + 1 ) = 0
C yes, tie it off
C writing to disk file
      if(.not.( putlun .eq. 21 ))goto 23004
      call wrtfil ( obuf , optr )
C writing to terminal
23004 continue
      if(.not.( putlun .eq. 5 ))goto 23006
      call ttsout ( obuf , 0 )
C  no CRLF
23006 continue
      optr = 0
C reset buffer pointer
23002 continue
      end
C getc - return next character from the input file
C 	character is returned in the argument AND as the function value
C 	a Newline character is returned when the end 0f a record is hit
C 	Eof is returned upon error or end-of-file
      integer function getc ( ch )
      integer ch
C character returned here
C cio - COMMON areas for Graphics Editor I/O
      common / cio / ip1 , iplast , optr , putlun , obuf , ibuf
      integer ip1
C subscript of last character fetched from ibuf
      integer iplast
C subscript of last character in ibuf
      integer optr
C subscript of last character stored in obuf
      integer putlun
C logical unit # for putc (either OUTLUN or TTYLUN)
      integer obuf ( 133 )
C buffer for output record (built by putc)
      integer ibuf ( 133 )
C input buffer used by getc
      integer i
      ip1 = ip1 + 1
C point to next character in ibuf
      if(.not.( ip1 .gt. iplast ))goto 23008
C end of this record?
      continue
       i = 132
23010 if(.not.(i.gt.0))goto 23012
      ibuf ( i ) = 32
23011 i=i-1
      goto 23010
23012 continue
C yes, clear buffer
      read ( 20 , 100 , end = 200 , err = 200 ) ( ibuf ( i ) , i = 1 , 1
     *32 )
100   format ( 132 r1 )
C set iplast to the subscript of the last non-blank in ibuf
      continue
       iplast = 132
23013 if(.not.(iplast.gt.0))goto 23015
      if(.not.( ibuf ( iplast ) .ne. 32 ))goto 23016
      goto 23015
23016 continue
23014 iplast=iplast-1
      goto 23013
23015 continue
      iplast = iplast + 1
      ibuf ( iplast ) = 10
C add Newline
      ip1 = 1
C back to 1st character
23008 continue
      ch = ibuf ( ip1 )
C give char as argument
      getc = ch
C give char as function value
      return
C end-of-file or error
200   getc = ( - 1 )
C return Eof to caller
      end
C inpfil - open a file for input; file is read via getc and getw
C  Filespec is taken from pathn (in cpath COMMON block)
C  returns:  -1 if open failed, 0 if open succeeded
      integer function inpfil ( noargs )
      integer noargs
C cio - COMMON areas for Graphics Editor I/O
      common / cio / ip1 , iplast , optr , putlun , obuf , ibuf
      integer ip1
C subscript of last character fetched from ibuf
      integer iplast
C subscript of last character in ibuf
      integer optr
C subscript of last character stored in obuf
      integer putlun
C logical unit # for putc (either OUTLUN or TTYLUN)
      integer obuf ( 133 )
C buffer for output record (built by putc)
      integer ibuf ( 133 )
C input buffer used by getc
      integer pathn ( 50 )
C inpfil, outfil expect to find pathname here
      integer bkgdnm ( 50 )
C filepsec of "background" file
      common / cpath / pathn , bkgdnm
C 3 characters plus Eos
      integer fnttyp ( 4 ) , pictyp ( 4 ) , rpftyp ( 4 )
      common / ctypes / fnttyp , pictyp , rpftyp
      logical openf
      inpfil = - 1
      if(.not.( openf ( 20 , pathn , 2 ) ))goto 23018
      inpfil = 0
23018 continue
      ip1 = 0
      iplast = 0
C force read of first record
      end
C outfil - open a file for output; file is written via putc and putw
C  Filespec is taken from pathn (in cpath COMMON block)
C  returns:  -1 if open failed, 0 if open succeeded
      integer function outfil ( noargs )
      integer noargs
C cio - COMMON areas for Graphics Editor I/O
      common / cio / ip1 , iplast , optr , putlun , obuf , ibuf
      integer ip1
C subscript of last character fetched from ibuf
      integer iplast
C subscript of last character in ibuf
      integer optr
C subscript of last character stored in obuf
      integer putlun
C logical unit # for putc (either OUTLUN or TTYLUN)
      integer obuf ( 133 )
C buffer for output record (built by putc)
      integer ibuf ( 133 )
C input buffer used by getc
      integer pathn ( 50 )
C inpfil, outfil expect to find pathname here
      integer bkgdnm ( 50 )
C filepsec of "background" file
      common / cpath / pathn , bkgdnm
C 3 characters plus Eos
      integer fnttyp ( 4 ) , pictyp ( 4 ) , rpftyp ( 4 )
      common / ctypes / fnttyp , pictyp , rpftyp
      logical openf
      call flusho
C flush any pending putc output
      outfil = - 1
      if(.not.( openf ( 21 , pathn , 1 ) ))goto 23020
C file opened OK?
      putlun = 21
C yes, set logical unit # to disk file
      outfil = 0
C tell caller I succeeded
23020 continue
      end
C putc - putc normally writes a character to the terminal; however, if
C 	outfil has been called, putc will write to a disk file. Calling
C 	clsout will direct putc output back to the terminal.
      subroutine putc ( ch )
      integer ch
C cio - COMMON areas for Graphics Editor I/O
      common / cio / ip1 , iplast , optr , putlun , obuf , ibuf
      integer ip1
C subscript of last character fetched from ibuf
      integer iplast
C subscript of last character in ibuf
      integer optr
C subscript of last character stored in obuf
      integer putlun
C logical unit # for putc (either OUTLUN or TTYLUN)
      integer obuf ( 133 )
C buffer for output record (built by putc)
      integer ibuf ( 133 )
C input buffer used by getc
      integer i
      if(.not.( ch .eq. 10 .or. optr .eq. 132 ))goto 23022
C have to write buffer?
      obuf ( optr + 1 ) = 0
C yes, tie it off
C writing to disk file
      if(.not.( putlun .eq. 21 ))goto 23024
      call wrtfil ( obuf , optr )
C writing to terminal
23024 continue
      if(.not.( putlun .eq. 5 ))goto 23026
      i = 0
      if(.not.( ch .eq. 10 ))goto 23028
      i = 1
23028 continue
C decide if CRLF wanted
      call ttsout ( obuf , i )
C write to tty
C 		call putarg(obuf)
23026 continue
      optr = 0
C reset buffer pointer
      if(.not.( ch .eq. 10 ))goto 23030
      return
23030 continue
C return if just newline
23022 continue
      optr = optr + 1
C step the pointer
      obuf ( optr ) = ch
C put char in buffer
      end
      block data
C cio - COMMON areas for Graphics Editor I/O
      common / cio / ip1 , iplast , optr , putlun , obuf , ibuf
      integer ip1
C subscript of last character fetched from ibuf
      integer iplast
C subscript of last character in ibuf
      integer optr
C subscript of last character stored in obuf
      integer putlun
C logical unit # for putc (either OUTLUN or TTYLUN)
      integer obuf ( 133 )
C buffer for output record (built by putc)
      integer ibuf ( 133 )
C input buffer used by getc
      data optr , putlun / 0 , 5 /
      data iplast / 0 / , ip1 / 0 /
      end
C wrtfil - write a bufferful of text to a file, breaking up into records
      subroutine wrtfil ( obuf , optr )
      integer optr
      integer obuf ( 132 )
      integer i , j , strt
C  write each "line" as a separate record
      if(.not.( optr .eq. 0 ))goto 23032
      write ( 21 , 100 )
C just an empty line
      return
23032 continue
      strt = 1
      continue
23034 if(.not.( strt .le. optr ))goto 23035
      continue
       i = strt
23036 if(.not.(i.le.optr.and.obuf(i).ne.10))goto 23038
C  find Newlines (LF's)
23037 i=i+1
      goto 23036
23038 continue
      if(.not.( i - 1 .ge. strt ))goto 23039
      write ( 21 , 100 ) ( obuf ( j ) , j = strt , i - 1 )
      goto 23040
23039 continue
      write ( 21 , 100 )
23040 continue
C null lines count!
100   format ( 132 r1 )
      strt = i + 1
      goto 23034
23035 continue
      return
      end