Trailing-Edge
-
PDP-10 Archives
-
BB-K818A-BM_1981
-
sources/icmdw.for
There are no other files named icmdw.for in the archive.
C icmdw> ReGIS input -- parse W command, temporary writing options
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 cmdw - process "W" command
subroutine cmdw
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
call rdwopt
C get new wops in wrkwop
call mrgopt ( wrkwop , prmwop , 10 , 0 )
C merge into permanent
C perm wops will be merged into temp wops in main command dispatch loop
end
C rdwopt - read writing options of the form W(options...)
C it is assumed the W has already been scanned
C returns data in wrkwop vector; if a writing option is absent,
C its corresponding entry in wrkwop is set to -1
subroutine rdwopt
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 , i , kgi , kgnum , kterm
continue
i = 1
23000 if(.not.(i.le.10))goto 23002
wrkwop ( i ) = - 1
23001 i=i+1
goto 23000
23002 continue
C clear wop vector
100 continue
C here when ) hit
continue
23003 continue
C find "("
call gnbc ( ch )
C get character
if(.not.( ch .eq. 40 ))goto 23006
goto 23005
C start option list
23006 continue
if(.not.( kterm ( ch ) .ne. 0 ))goto 23008
C terminator?
call putbak ( ch )
C yes, put it back
return
23008 continue
call skpbal ( ch )
C skip [] () " "
C identify writing option and dispatch to its processor
23004 goto 23003
23005 continue
continue
23010 continue
call gnbc ( ch )
C get character
if(.not.( ch .eq. 59 .or. ch .eq. 41 ))goto 23013
goto 23012
goto 23014
23013 continue
if(.not.( ch .eq. 44 ))goto 23015
goto 23011
C ,
goto 23016
23015 continue
if(.not.( ch .eq. 97 ))goto 23017
C Alternate
if(.not.( kgnum ( i ) .ne. 0 ))goto 23019
C valid number?
if(.not.( i .ne. 0 ))goto 23021
i = 1
23021 continue
C yes
wrkwop ( 8 ) = i
C set alternate wop
23019 continue
goto 23018
23017 continue
if(.not.( ch .eq. 99 ))goto 23023
C Complement
wrkwop ( 1 ) = 2
goto 23024
23023 continue
if(.not.( ch .eq. 101 ))goto 23025
C Erase
wrkwop ( 1 ) = 1
goto 23026
23025 continue
if(.not.( ch .eq. 105 ))goto 23027
C Intensity
if(.not.( kgi ( i ) .lt. 2 ))goto 23029
C valid color?
wrkwop ( 9 ) = i
23029 continue
C yes, save it
goto 23028
23027 continue
if(.not.( ch .eq. 109 ))goto 23031
C Multiplier
if(.not.( kgnum ( i ) .ne. 0 ))goto 23033
C valid number?
wrkwop ( 7 ) = i
23033 continue
C yes, set pixel mult
goto 23032
23031 continue
if(.not.( ch .eq. 110 ))goto 23035
C Negate
if(.not.( kgnum ( i ) .ne. 0 ))goto 23037
C valid number?
if(.not.( i .ne. 0 ))goto 23039
i = 1
23039 continue
C yes
wrkwop ( 2 ) = i
C set image-type wop
23037 continue
goto 23036
23035 continue
if(.not.( ch .eq. 112 ))goto 23041
C Pattern
continue
23043 continue
call wsubp ( i )
23044 if(.not.( i .eq. 0 ))goto 23043
23045 continue
goto 23042
23041 continue
if(.not.( ch .eq. 114 ))goto 23046
C Replace
wrkwop ( 1 ) = 0
goto 23047
23046 continue
if(.not.( ch .eq. 115 ))goto 23048
C Shade
wrkwop ( 5 ) = 0
C assume shading off
continue
23050 continue
call wsubs ( i )
23051 if(.not.( i .eq. 0 ))goto 23050
23052 continue
goto 23049
23048 continue
if(.not.( ch .eq. 118 ))goto 23053
C oVerlay
wrkwop ( 1 ) = 3
goto 23054
23053 continue
C unknown option to W command
call imerr ( 2 )
C signal error
call cfind ( 41 )
C skip to ) or Sync
return
23054 continue
23049 continue
23047 continue
23042 continue
23036 continue
23032 continue
23028 continue
23026 continue
23024 continue
23018 continue
23016 continue
23014 continue
23011 goto 23010
23012 continue
goto 100
C try for another (
end
C scantw - scan temporary writing options; just like "cmdw" routine,
C except it doesn't change the permanent options.
C it is assumed the W has already been scanned
subroutine scantw
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
call rdwopt
C get new wops in wrkwop
call mrgopt ( wrkwop , tmpwop , 10 , 127 )
C merge new into temp
C and create gelly
end
C wsubp - process P option of W command
subroutine wsubp ( result )
integer result
C set to 1 if something parsed, else 0
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 , bit , i , kgnum , kterm , n , pat
result = 1
C assume success
call gnbc ( ch )
C get potential 0-9 or (
if(.not.( 50 .le. ch .and. ch .le. 57 ))goto 23055
C 2-9
wrkwop ( 3 ) = ( ch - 48 ) * 256
goto 23056
23055 continue
if(.not.( ch .eq. 48 .or. ch .eq. 49 ))goto 23057
C 0 or 1
bit = 128
C 10000000 binary
continue
n = 0
23059 if(.not.(ch.eq.48.or.ch.eq.49))goto 23061
if(.not.( ch .eq. 49 ))goto 23062
pat = pat + bit
23062 continue
bit = bit / 2
C shift bit right 1 place
call gnbc ( ch )
C get next character
23060 n=n+1
goto 23059
23061 continue
call putbak ( ch )
C restore char after 10101 stuff
C replicate the pattern if it's shorter than 8 bits
wrkwop ( 3 ) = 0
C clear wop entry
continue
23064 continue
wrkwop ( 3 ) = wrkwop ( 3 ) + pat
continue
i = n
23067 if(.not.(i.gt.0))goto 23069
pat = pat / 2
23068 i=i-1
goto 23067
23069 continue
C next replication
23065 if(.not.( pat .eq. 0 ))goto 23064
23066 continue
goto 23058
23057 continue
if(.not.( ch .eq. 40 ))goto 23070
continue
23072 continue
call gnbc ( ch )
C W(P(what?
if(.not.( ch .eq. 41 ))goto 23075
goto 23074
C )
goto 23076
23075 continue
if(.not.( ch .eq. 109 ))goto 23077
C Mn
if(.not.( kgnum ( i ) .ne. 0 ))goto 23079
wrkwop ( 4 ) = i
23079 continue
goto 23078
23077 continue
call imerr ( 3 )
C not (M
call cfind ( 41 )
C skip to next )
goto 23074
23078 continue
23076 continue
23073 goto 23072
23074 continue
return
goto 23071
23070 continue
C not a valid P thing
C error if character is not one of: ) , a-z Sync
if(.not.( kterm ( ch ) .eq. 0 .and. ch .ne. 44 ))goto 23081
call imerr ( 3 )
23081 continue
call putbak ( ch )
C put character back
result = 0
C tell caller no more P stuff
23071 continue
23058 continue
23056 continue
end
C wsubs - process S option of W command
subroutine wsubs ( result )
integer result
C set to 1 if something parsed, else 0
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 , i , kgnum , quotch , rdpos , y1
result = 1
C assume success
call gnbc ( ch )
C S what?
call putbak ( ch )
if(.not.( ch .eq. 39 .or. ch .eq. 34 ))goto 23083
C S" or S'
call gnbc ( ch )
C eat delimiter again
i = quotch ( ch )
C get 1st char of string
if(.not.( i .ge. 32 ))goto 23085
wrkwop ( 5 ) = i
23085 continue
goto 23084
23083 continue
if(.not.( ch .eq. 91 ))goto 23087
C S[
y1 = ypos
C initialize Y
i = rdpos ( cdum , y1 )
C [,y] ... get Y in y1
if(.not.( i .gt. 0 .and. y1 .ge. 0 ))goto 23089
wrkwop ( 6 ) = y1
C set shadey
C if shading is not already on, turn it on
if(.not.( wrkwop ( 5 ) .eq. 0 ))goto 23091
wrkwop ( 5 ) = 1
23091 continue
23089 continue
goto 23088
23087 continue
if(.not.( kgnum ( i ) .gt. 0 ))goto 23093
wrkwop ( 5 ) = i
C Snumber
goto 23094
23093 continue
result = 0
C nothing parsed
C if shading on and [,y] not specified, generate an explicit Shadyax wop
23094 continue
23088 continue
23084 continue
if(.not.( wrkwop ( 5 ) .gt. 0 .and. wrkwop ( 6 ) .eq. - 1 ))goto 2
*3095
wrkwop ( 6 ) = ypos
23095 continue
end