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