Trailing-Edge
-
PDP-10 Archives
-
BB-K818A-BM_1981
-
sources/isub.for
There are no other files named isub.for in the archive.
C isub> ReGIS input -- Miscellaneous subroutines
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 unlikely X coordinate
C angpv - convert an angle in degrees to a pixel-vector (0-7)
integer function angpv ( ang )
integer ang
C angle in degrees
integer i
i = ang / 45
C scale down
i = mod ( i , 8 )
C -7 <= i <= 7
if(.not.( i .lt. 0 ))goto 23000
i = i + 8
23000 continue
C 0 <= i <= 7
angpv = i
C ship it
end
C geld1 - delete the last gel from the gel vector
subroutine geld1
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
if(.not.( goflo .ne. 0 ))goto 23002
return
23002 continue
C overflow, it doesn't matter
dollar = dollar - 1
C back up 1 gel
gel ( dollar ) = 0
C my holiday's complete
end
C gel1 - add a gel to the end of the "gel" vector
C Note: gel1 never lets dollar get larger than Maxgels - 1
C returns: subscript of gel vector where the new value was stored
integer function gel1 ( newgel )
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
integer newgel
C gel to be added
gel1 = dollar
C tell caller where the gel is
if(.not.( goflo .ne. 0 ))goto 23004
return
23004 continue
C no action if oflo already reported
if(.not.( dollar .ge. 3000 - 1 ))goto 23006
C overflow?
call imerr ( 1 )
C yes, tell user
goflo = 1
C remember that overflow occurred
return
23006 continue
gel ( dollar ) = newgel
C add the gel
dollar = dollar + 1
C next available slot
gel ( dollar ) = 0
C install terminator
end
C gel2 - add 2 gels to the end of the "gel" vector
C returns: subscript of gel vector where first new value was stored
integer function gel2 ( new1 , new2 )
integer new1 , new2
integer gel1
gel2 = gel1 ( new1 )
gel2 = gel1 ( new2 ) - 1
end
C geln - allocate room for "n" gels
C returns: subscript of gel vector where first new value allocated
integer function geln ( n )
integer n
integer gel1
geln = gel1 ( 0 )
C first gel
if(.not.( n .ge. 2 ))goto 23008
do 23010 i = 2 , n
call gel1 ( 0 )
23010 continue
23011 continue
23008 continue
C zero the gels
end
C mrgopt - merge one text or writing option vector into another,
C optionally producing gelly to reflect the differences
C -1 values in "from" vector don't change the "to" vector
subroutine mrgopt ( from , to , len , base )
integer from ( 1 )
C "from" vector
integer to ( 1 )
C "to" vector (gets changed)
integer len
C Toplen or Woplen
integer base
C 0 for no gelly, else Topbase or Wopbase
integer f , i , x
continue
i = 1
23012 if(.not.(i.le.len))goto 23014
f = from ( i )
if(.not.( f .ne. - 1 .and. to ( i ) .ne. f ))goto 23015
C change this option?
to ( i ) = f
C yes, do it
if(.not.( base .ne. 0 ))goto 23017
C want to make gelly?
x = base + i
C yes
call gel2 ( x , f )
C write gel type code
C and option value
23017 continue
23015 continue
23013 i=i+1
goto 23012
23014 continue
end
C mv2loc - when inrgis reads the ReGIS input, it appends the gelly
C to the end of gel. When Eof is hit, inrgis calls
C mv2loc to relocate the new gelly to the position that
C was specified in the "read" command (the "loc" arg).
subroutine mv2loc ( loc , orgdol )
integer loc
C subscript of gel where new gelly goes
integer orgdol
C value of dollar when inrgis was called
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
integer i , j , tmp
continue
j = orgdol - loc
23019 if(.not.(j.gt.0))goto 23021
C number of shifts
tmp = gel ( loc )
C save bottom
continue
i = loc + 1
23022 if(.not.(i.lt.dollar))goto 23024
gel ( i - 1 ) = gel ( i )
23023 i=i+1
goto 23022
23024 continue
gel ( dollar - 1 ) = tmp
C put bottom at top
23020 j=j-1
goto 23019
23021 continue
end
C nullxy - put a null entry on the X-Y stack; when this entry is
C popped, it will have no effect upon xpos and ypos
subroutine nullxy
C cram> GIGI "RAM" common
C size of coordinate stack (P,V,C commands)
integer prmtop ( 10 )
C permanent text options
integer wrkwop ( 10 )
C filled in by rdwopt
integer prmwop ( 10 )
C permanent writing options
integer tmpwop ( 10 )
C temporary writing options
integer xpos , ypos
C coordinates of current cursor position
integer xystak ( 10 , 2 )
C coordinate stack (P,V commands)
integer xysp
C coordinate stack pointer
integer cdum
C garbage argument for rdpos
common / cram / prmtop , wrkwop , prmwop , tmpwop , xpos , ypos ,
*xystak , xysp , cdum
if(.not.( xysp .ge. 10 ))goto 23025
return
23025 continue
C no action if overflow
xysp = xysp + 1
C increment pointer
xystak ( xysp , 1 ) = 32442
C push bogus x value
end
C pckarb - convert chars stored in "int" to chars stored in "char" array
subroutine pckarb ( i , c , n )
integer i ( 1 )
integer c ( 1 )
integer n , j
continue
j = 1
23027 if(.not.(i(j).ne.0.and.j.lt.n))goto 23029
c ( j ) = i ( j )
23028 j=j+1
goto 23027
23029 continue
c ( j ) = 0
end
C pckgel - pack the string in the gel vector
subroutine pckgel ( gp )
integer gp
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
call pckarb ( gel ( gp ) , gel ( gp ) , 3000 - gp )
end
C popxy - pop X and Y coordinates from stack
subroutine popxy
C cram> GIGI "RAM" common
C size of coordinate stack (P,V,C commands)
integer prmtop ( 10 )
C permanent text options
integer wrkwop ( 10 )
C filled in by rdwopt
integer prmwop ( 10 )
C permanent writing options
integer tmpwop ( 10 )
C temporary writing options
integer xpos , ypos
C coordinates of current cursor position
integer xystak ( 10 , 2 )
C coordinate stack (P,V commands)
integer xysp
C coordinate stack pointer
integer cdum
C garbage argument for rdpos
common / cram / prmtop , wrkwop , prmwop , tmpwop , xpos , ypos ,
*xystak , xysp , cdum
if(.not.( xysp .le. 0 ))goto 23030
return
23030 continue
C can't pop empty stack
if(.not.( xystak ( xysp , 1 ) .ne. 32442 ))goto 23032
C null entry?
xpos = xystak ( xysp , 1 )
C no, pop x
ypos = xystak ( xysp , 2 )
C and y
23032 continue
xysp = xysp - 1
C decrement pointer
end
C pushxy - push current X and Y coordinates on stack
C implements P(B) V(B) C(B)
subroutine pushxy
C cram> GIGI "RAM" common
C size of coordinate stack (P,V,C commands)
integer prmtop ( 10 )
C permanent text options
integer wrkwop ( 10 )
C filled in by rdwopt
integer prmwop ( 10 )
C permanent writing options
integer tmpwop ( 10 )
C temporary writing options
integer xpos , ypos
C coordinates of current cursor position
integer xystak ( 10 , 2 )
C coordinate stack (P,V commands)
integer xysp
C coordinate stack pointer
integer cdum
C garbage argument for rdpos
common / cram / prmtop , wrkwop , prmwop , tmpwop , xpos , ypos ,
*xystak , xysp , cdum
if(.not.( xysp .ge. 10 ))goto 23034
return
23034 continue
C no action if overflow
xysp = xysp + 1
C increment pointer
xystak ( xysp , 1 ) = xpos
C push X
xystak ( xysp , 2 ) = ypos
C push Y
end
C pvmove - compute X and Y increments given pixel vector direction
C and magnitude
C dir: 3 2 1
C \ | /
C 4 --*-- 0
C / | \
C 5 6 7
subroutine pvmove ( dir , mag , xi , yi )
integer dir
C direction (0-7, see above)
integer mag
C magnitude
integer xi , yi
C pvmove returns X and Y increments here
integer n
n = mag
C local copy
xi = 0
yi = 0
goto ( 500 , 501 , 502 , 503 , 504 , 505 , 506 , 507 ) , dir + 1
500 xi = n
goto 510
501 xi = n
yi = - n
goto 510
502 yi = - n
goto 510
503 xi = - n
yi = - n
goto 510
504 xi = - n
goto 510
505 xi = - n
yi = n
goto 510
506 yi = n
goto 510
507 xi = n
yi = n
510 continue
end
C rdpos - parse a position specification and update X and Y values.
C The ReGIS syntax of a positon specification is either:
C 1. [{{sign}xnum}{,}{{sign}ynum}]
C Note: Braces {} denote optional quantities
C 2. A digit from the set
C 3 2 1
C \ | /
C 4 --*-- 0
C / | \
C 5 6 7
C Example: assume x1 = 432, y1 = 239
C the ReGIS position spec is: [+10,98]
C call rdpos(x1,y1)
C now, x1 = 442, y1 = 98
C returns: 0 no valid coordinate specification found
C 1 bracketed spec parsed
C 2 pixel-vector spec parsed
integer function rdpos ( xp , yp )
integer xp , yp
C modified to reflect new position
C cram> GIGI "RAM" common
C size of coordinate stack (P,V,C commands)
integer prmtop ( 10 )
C permanent text options
integer wrkwop ( 10 )
C filled in by rdwopt
integer prmwop ( 10 )
C permanent writing options
integer tmpwop ( 10 )
C temporary writing options
integer xpos , ypos
C coordinates of current cursor position
integer xystak ( 10 , 2 )
C coordinate stack (P,V commands)
integer xysp
C coordinate stack pointer
integer cdum
C garbage argument for rdpos
common / cram / prmtop , wrkwop , prmwop , tmpwop , xpos , ypos ,
*xystak , xysp , cdum
integer ch , kgnum , n , xi , yi
call gnbc ( ch )
C which form?
if(.not.( ch .eq. 91 ))goto 23036
C [x,y]
goto ( 300 , 301 , 302 ) , kgnum ( n ) + 1
C parse X
301 xp = n
C unsigned (absolute)
goto 300
302 xp = xp + n
C signed (relative)
300 continue
C no X coord
call gnbc ( ch )
C get character after X
if(.not.( ch .eq. 44 ))goto 23038
C comma?
goto ( 400 , 401 , 402 ) , kgnum ( n ) + 1
C yes, parse Y
401 yp = n
C unsigned (absolute)
goto 400
402 yp = yp + n
C signed (relative)
400 call gnbc ( ch )
C get char after Y coord
23038 continue
if(.not.( ch .ne. 93 ))goto 23040
C terminating ] present?
call imerr ( 4 )
C no, signal error
call cfind ( 93 )
C find ] or Sync
23040 continue
rdpos = 1
C bracket-form parsed
return
23036 continue
if(.not.( ch .ge. 48 .and. ch .le. 55 ))goto 23042
C pixel-vector form?
ch = ch - 48
C yes, get direction
call pvmove ( ch , tmpwop ( 7 ) , xi , yi )
C compute X, Y increments
xpos = xpos + xi
ypos = ypos + yi
C adjust X and Y
rdpos = 2
C pixel-vector form
return
23042 continue
call putbak ( ch )
rdpos = 0
C nothing parsed
end
C tstxy - check what's at the top of the XY stack
C returns: 1 - last XY pair on stack was put there by pushxy
C 0 - stack empty, or top of stack was put there by nullxy
integer function tstxy ( dum )
C cram> GIGI "RAM" common
C size of coordinate stack (P,V,C commands)
integer prmtop ( 10 )
C permanent text options
integer wrkwop ( 10 )
C filled in by rdwopt
integer prmwop ( 10 )
C permanent writing options
integer tmpwop ( 10 )
C temporary writing options
integer xpos , ypos
C coordinates of current cursor position
integer xystak ( 10 , 2 )
C coordinate stack (P,V commands)
integer xysp
C coordinate stack pointer
integer cdum
C garbage argument for rdpos
common / cram / prmtop , wrkwop , prmwop , tmpwop , xpos , ypos ,
*xystak , xysp , cdum
integer dum
C dummy
tstxy = 0
C assume empty or null
if(.not.( xysp .gt. 0 ))goto 23044
C anything there?
if(.not.( xystak ( xysp , 1 ) .ne. 32442 ))goto 23046
tstxy = 1
23046 continue
23044 continue
C yes, examine it
end