Google
 

Trailing-Edge - PDP-10 Archives - BB-K818A-BM_1981 - sources/iqcom.for
There are no other files named iqcom.for in the archive.
C iqcom> ReGIS input -- Process quoted commands  ;"..."
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 Error code definitions for imerr subroutine
C These represent errors detected while reading a ReGIS file
C gel vector overflow
C Illegal syntax in W command
C Illegal syntax in P option of W command
C Illegal [x,y] coordinate specification
C Macrograph defined or deleted within a macrograph
C Illegal character after @
C Attempt to define non-alpha macrograph
C Macrograph storage exhausted
C Macrograph calls nested too deeply
C Illegal syntax in L command
C Illegal syntax in R command
C Illegal syntax in S command
C Illegal syntax in V command
C Illegal syntax in P command
C Illegal syntax in C command
C Illegal syntax in T command
C fewer than 2 points in closed curve
C fewer than 3 points in open curve
C C(B) or C(S) terminated prematurely
C Illegal label or object name
C ;"}" found and no object was open
C Eof hit and open object(s) exist
C Putbak error - not your fault
C Too many points in line
C Too many points in curve
C maximum size of object names and tags
C cstrg - process ;"..." constructs in the input character stream.
C 	 The VK100 would ignore these as comments, but they have
C 	 special significance to the Graphics Editor.  The following
C 	 forms are currently recognized:
C 		;".command"	Special command to the processor
C 		;":label"	A tag within the ReGIS file
C 		;":objname{"	The beginning of an object, whose
C 				name is objname.  An object is
C 				simply a set of ReGIS commands.
C 		;"}"		The end of an object.  Objects may
C 				be nested, for example
C 				  ;":ob1{" ... ;":ob2{" ... ;"}" ...
C 				  ;":ob3{" ... ;"}" ... ;"}"
C 	Unrecognized forms are ignored.
C 	It is assumed that eattxt has already parsed the construct,
C 	and the guts now live (without the ; and quotes) in qbuf.
      subroutine cstrg
C crget> COMMON for "get next ReGIS character" subroutine group
C size of qbuf (Maxobj + 5)
      logical gcgel
C .true. tells gnc to copy returned characters into gel
      integer peekc
C character that was put back to putbak (-1 if none)
      integer qbuf ( 15 )
C text from quoted strings copied here
      integer syncfl
C non-zero if Sync or Eof hit and ksync(1) hasn't
C been called yet; syncfl contains 0, Sync, or Eof
      common / crget / peekc , syncfl , gcgel , qbuf
      integer q1 , q2 , q3 , q4
C for easy reference to qbuf elements
      equivalence ( q1 , qbuf ( 1 ) )
      equivalence ( q2 , qbuf ( 2 ) )
      equivalence ( q3 , qbuf ( 3 ) )
      equivalence ( q4 , qbuf ( 4 ) )
      integer ch , eqstr , i , i1 , letter , obnest , gel1 , sstart
      integer xlit ( 8 ) , xelit ( 5 )
      data xlit ( 1 ) , xlit ( 2 ) , xlit ( 3 ) , xlit ( 4 ) / 108 , 105
     * , 116 , 101 /
      data xlit ( 5 ) , xlit ( 6 ) , xlit ( 7 ) , xlit ( 8 ) / 114 , 97 
     *, 108 , 0 /
      data xelit ( 1 ) , xelit ( 2 ) , xelit ( 3 ) , xelit ( 4 ) , xelit
     * ( 5 ) / 59 , 34 , 46 , 34 , 0 /
      if(.not.( q1 .eq. 58 ))goto 23000
C tag or start of object
      ch = q2
C convert to int for "letter"
      if(.not.( letter ( ch ) .eq. 0 ))goto 23002
      goto 200
23002 continue
C must start with a letter
      i = 2
      continue
23004 continue
C find the end of the name
      i = i + 1
C step to next character
      ch = qbuf ( i )
C get it
23005 if(.not.( letter ( ch ) .eq. 0 .and. ( ch .lt. 48 .or. ch .gt. 57 
     *) ))goto 23004
23006 continue
      if(.not.( i .gt. 10 + 2 ))goto 23007
      goto 200
23007 continue
C error if too long
      if(.not.( ch .eq. 0 ))goto 23009
      call gel1 ( 11 )
C :name
      goto 23010
23009 continue
      if(.not.( ch .eq. 123 .and. qbuf ( i + 1 ) .eq. 0 ))goto 23011
C :name{
      call gel1 ( 12 )
      i1 = obnest ( 1 )
C increment nesting level
      goto 23012
23011 continue
      goto 200
23012 continue
23010 continue
C not :name or :name{
      sstart = gel1 ( 0 )
C dummy to get start of string
      call geld1
C delete it
      continue
       i1 = 2
23013 if(.not.(i1.lt.i))goto 23015
C copy name to gelly
      ch = qbuf ( i1 )
      call gel1 ( ch )
23014 i1=i1+1
      goto 23013
23015 continue
      call gel1 ( 0 )
C tie off the gel
      call pckgel ( sstart )
C pack string in gel
      return
C some error detected in tag or object name
200   call imerr ( 20 )
C signal error to user
      return
23000 continue
      if(.not.( q1 .eq. 46 ))goto 23016
C ;".command"
      call qshift
C delete the dot
      if(.not.( eqstr ( qbuf , xlit ) .ne. 0 ))goto 23018
C .literal?
      continue
       i = 5
23020 if(.not.(i.gt.0))goto 23022
      qbuf ( i ) = 0
23021 i=i-1
      goto 23020
23022 continue
C clear qbuf
      call gel1 ( ( - 1 ) )
C start Garbgel
      sstart = gel1 ( 0 )
C dummy to get start of string
      call geld1
C delete it
      continue
23023 continue
      call gnc ( ch )
C get next character
      if(.not.( ch .eq. ( - 1 ) ))goto 23026
C Eof?
      continue
       i = 1
23028 if(.not.(i.le.4))goto 23030
C yes
      ch = qbuf ( i )
C flush cache
      if(.not.( ch .ne. 0 ))goto 23031
      call gel1 ( ch )
23031 continue
23029 i=i+1
      goto 23028
23030 continue
      goto 23025
C stop scanning
23026 continue
      i = q1
      q1 = q2
      q2 = q3
      q3 = q4
      q4 = ch
      if(.not.( i .ne. 0 ))goto 23033
C something coming out yet?
      call gel1 ( i )
C yes, Garbgel it
C if ;"." seen, get out of loop
      if(.not.( eqstr ( qbuf , xelit ) .ne. 0 ))goto 23035
      goto 23025
23035 continue
23033 continue
23024 goto 23023
23025 continue
      call gel1 ( 0 )
C tie off the Garbgel
      call pckgel ( sstart )
C pack string in gel vector
23018 continue
      return
23016 continue
      if(.not.( q1 .eq. 125 .and. q2 .eq. 0 ))goto 23037
C   ;"}"
C generate Closegel only if there are any objects open
      if(.not.( obnest ( 2 ) .eq. 0 ))goto 23039
      call gel1 ( 13 )
23039 continue
C generate gelly
      return
23037 continue
      end
C obnest - detect errors in object nesting
C 	  Function codes:
C 		1 - Add a nesting level
C 		2 - Delete a nesting level
C 		3 - Check for open nestings at end-of-file
C  returns:  Value based upon function code:
C 		func 1:  0 always
C 		func 2:  0 if OK, 1 if no object currently open
C 		finc 3:  0 if OK, else number of unclosed objects
      integer function obnest ( fnc )
      integer fnc
C function code (see above)
      integer nest
C current nesting level
      data nest / 0 /
      obnest = 0
C default answer
      goto ( 201 , 202 , 203 ) , fnc
C dispatch off func code
201   nest = nest + 1
C add nesting level
      return
202   nest = nest - 1
C delete nesting level
      if(.not.( nest .lt. 0 ))goto 23041
C deleted too many?
      nest = 0
C yes, fix it
      call imerr ( 21 )
C report error to user
      obnest = 1
C report error to caller
23041 continue
      return
203   if(.not.( nest .gt. 0 ))goto 23043
C anything open?
      obnest = nest
C yes, tell caller how many
      nest = 0
C close them all
      call imerr ( 22 )
C report error to user
23043 continue
      return
      end
C qshift - shift everything in qbuf one character to the left,
C 	  converting upper case to lower case (note that the
C 	  first character in qbuf is lost in the process)
      subroutine qshift
C crget> COMMON for "get next ReGIS character" subroutine group
C size of qbuf (Maxobj + 5)
      logical gcgel
C .true. tells gnc to copy returned characters into gel
      integer peekc
C character that was put back to putbak (-1 if none)
      integer qbuf ( 15 )
C text from quoted strings copied here
      integer syncfl
C non-zero if Sync or Eof hit and ksync(1) hasn't
C been called yet; syncfl contains 0, Sync, or Eof
      common / crget / peekc , syncfl , gcgel , qbuf
      integer ch , i
      i = 0
      continue
23045 continue
      i = i + 1
      ch = qbuf ( i + 1 )
C get character
      call lower ( ch )
C convert to lower case
      qbuf ( i ) = ch
C shift it
23046 if(.not.( ch .eq. 0 ))goto 23045
23047 continue
C stop at end of string
      end