Trailing-Edge
-
PDP-10 Archives
-
BB-K818A-BM_1981
-
sources/icmd0.for
There are no other files named icmd0.for in the archive.
C icmd0> ReGIS input -- L, P, R, and S 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 cmdl - process "L" command; some syntax checking is done, but for the
C most part, the command is passed intact as a Garbgel
subroutine cmdl
integer ch
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
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 kterm , sstart , gel1
call gel1 ( ( - 1 ) )
C start Garbgel, L cmd
sstart = gel1 ( 76 )
C save start of string
C request that gnc automatically copy characters to gelly
gcgel = . true .
continue
23000 continue
call gnbc ( ch )
C get char after L
if(.not.( kterm ( ch ) .ne. 0 ))goto 23003
goto 23002
C end of L command
23003 continue
if(.not.( ch .eq. 40 ))goto 23005
C options present?
continue
23007 continue
C yes, scan them
call gnbc ( ch )
C get option character
if(.not.( ch .eq. 97 ))goto 23010
C A ?
continue
23012 continue
C yes
call gnbc ( ch )
C A what, Jim?
call putbak ( ch )
if(.not.( kterm ( ch ) .ne. 0 ))goto 23015
goto 23014
23015 continue
if(.not.( ch .eq. 39 .or. ch .eq. 34 ))goto 23017
call gnbc ( ch )
C A"name"
call eattxt ( ch )
C "x"
goto 23018
23017 continue
call kgnum ( ch )
23018 continue
C Anumber
23013 goto 23012
23014 continue
goto 23011
23010 continue
if(.not.( ch .eq. 41 .or. ch .eq. 59 ))goto 23019
goto 23009
goto 23020
23019 continue
if(.not.( ch .ne. 44 ))goto 23021
call imerr ( 10 )
23021 continue
23020 continue
23011 continue
23008 goto 23007
23009 continue
goto 23006
23005 continue
if(.not.( ch .eq. 39 .or. ch .eq. 34 ))goto 23023
C quoted character?
call eattxt ( ch )
C yes, eat it
C scan the hexadecimal definition of the character
continue
23025 continue
call gnbc ( ch )
23026 if(.not.( . not . ( ( ch .ge. 48 .and. ch .le. 57 ) .or. ( ch .ge.
* 97 .and. ch .le. 102 ) ) ))goto 23025
23027 continue
C get next char
call putbak ( ch )
C put non-hex back
goto 23024
23023 continue
call imerr ( 10 )
23024 continue
23006 continue
C bogus character
23001 goto 23000
23002 continue
call putbak ( ch )
gcgel = . false .
C turn off auto-copy
if(.not.( gel ( dollar - 1 ) .ne. 59 ))goto 23028
call gel1 ( 59 )
23028 continue
C tie it off with Sync
call gel1 ( 0 )
C and a null
call pckgel ( sstart )
C pack the string in "gel" array
end
C cmdp - process "P" command
subroutine cmdp
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
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 , kterm , rdpos
C scan next element of P command, either position spec or (options)
continue
23030 continue
C if it's a position spec, just update xpos and ypos
if(.not.( rdpos ( xpos , ypos ) .ne. 0 ))goto 23033
goto 23031
C position spec?
23033 continue
call gnbc ( ch )
C no
if(.not.( kterm ( ch ) .ne. 0 ))goto 23035
C end of P command?
call putbak ( ch )
C yes, put it back
goto 23032
C wrap up P command
23035 continue
if(.not.( ch .eq. 40 ))goto 23037
C option list?
continue
23039 continue
C yes
call gnbc ( ch )
C get next option
if(.not.( ch .eq. 41 .or. ch .eq. 59 ))goto 23042
goto 23041
C end of options
23042 continue
if(.not.( ch .eq. 98 ))goto 23044
C B ?
call pushxy
C yes, put XY on stack
goto 23045
23044 continue
if(.not.( ch .eq. 101 ))goto 23046
C E ?
call popxy
C yes, get stacked XY
goto 23047
23046 continue
if(.not.( ch .eq. 115 ))goto 23048
C S ?
call nullxy
C yes, stack null entry
goto 23049
23048 continue
if(.not.( ch .eq. 119 ))goto 23050
C W ?
call scantw
C yes, temp writing opts
C Note: the pixel multiplier is the only
C temp wop that it is meaningful to set here
goto 23051
23050 continue
if(.not.( ch .ne. 44 ))goto 23052
C comma?
call imerr ( 14 )
C no, signal bad P option
call cfind ( 41 )
C skip to ) or Sync
goto 23041
23052 continue
23051 continue
23049 continue
23047 continue
23045 continue
23040 goto 23039
23041 continue
goto 23038
23037 continue
call imerr ( 14 )
23038 continue
C not position spec or (
23031 goto 23030
23032 continue
end
C cmdr - process "R" command; some syntax checking is done, but for the
C most part, the command is passed intact as a Garbgel
subroutine cmdr
integer ch , kterm
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
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 sstart , gel1
call gel1 ( ( - 1 ) )
C start Garbgel, R cmd
sstart = gel1 ( 82 )
C save start of string
C request that gnc automatically copy characters to gelly
gcgel = . true .
continue
23054 continue
call gnbc ( ch )
C char after R or R(...)
if(.not.( kterm ( ch ) .ne. 0 ))goto 23057
goto 23056
C break if terminator hit
23057 continue
if(.not.( ch .eq. 40 ))goto 23059
C R( ?
call gnbc ( ch )
C yes, get option
if(.not.( ch .eq. 109 .or. ch .eq. 112 ))goto 23061
C R(M or R(P ?
call gnbc ( ch )
C yes
if(.not.( ch .eq. 40 ))goto 23063
call cfind ( 41 )
goto 23064
23063 continue
call putbak ( ch )
23064 continue
goto 23062
23061 continue
if(.not.( ch .ne. 108 ))goto 23065
call imerr ( 11 )
23065 continue
23062 continue
C unknown option
call cfind ( 41 )
C R(...)
goto 23060
23059 continue
if(.not.( ch .ne. 59 ))goto 23067
call imerr ( 11 )
23067 continue
23060 continue
C not R( or R;
23055 goto 23054
23056 continue
call putbak ( ch )
C put back unwanted char
call gel1 ( 0 )
C terminate gel with null
gcgel = . false .
C turn off auto-copy
call pckgel ( sstart )
C pack string into gel vector
end
C cmds - process "S" command
C The E option is converted to an Erasegel.
C The I option is output as a Bakgrnd wop.
C The W option invokes temporary writing options; Inkolor is
C meaningful during a screen erase, and if an erase is done,
C any temp wops in effect at the end of the S command become
C perm wops.
C All the other S command stuff is passed thru as Garbgels
subroutine cmds
integer ch , intens , kterm , xgel
logical erasfl
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
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
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
erasfl = . false .
C E option not seen (yet)
continue
23069 continue
call gnbc ( ch )
C get character
if(.not.( ch .eq. 91 .or. ( ch .ge. 48 .and. ch .le. 55 ) ))goto 2
*3072
C scrolling?
call putbak ( ch )
C yes, put it back
call garbs ( 1 )
C begin S Garbgel
gcgel = . true .
C copy spec to gelly
call rdpos ( cdum , cdum )
C parse scrolling spec
gcgel = . false .
C stop copying
goto 23070
23072 continue
if(.not.( kterm ( ch ) .ne. 0 ))goto 23074
goto 23071
C break if terminator hit
23074 continue
if(.not.( ch .eq. 40 ))goto 23076
C S( ?
continue
23078 continue
C yes, loop to scan opts
call gnbc ( ch )
C get option
if(.not.( ch .eq. 41 .or. ch .eq. 59 ))goto 23081
goto 23080
23081 continue
if(.not.( ch .eq. 97 ))goto 23083
C S(A ?
call garbs ( 1 )
C start Garbgel
call gel2 ( 40 , 65 )
gcgel = . true .
C copy [..][..] to gelly
call rdpos ( cdum , cdum )
C parse 1st pair
call rdpos ( cdum , cdum )
C parse 2nd pair
goto 23084
23083 continue
if(.not.( ch .eq. 101 ))goto 23085
C S(E ?
call garbs ( 0 )
C yes
call gel1 ( 10 )
C Erasegel
if(.not.( tmpwop ( 5 ) .ne. 0 ))goto 23087
C shading?
tmpwop ( 5 ) = 0
C no more!
xgel = 127 + 5
call gel2 ( xgel , 0 )
C make wop
23087 continue
erasfl = . true .
C remember E seen
xysp = 0
C clear XY stack
goto 23086
23085 continue
if(.not.( ch .eq. 104 ))goto 23089
C S(H ?
call garbs ( 1 )
C start Garbgel
call gel2 ( 40 , 72 )
gcgel = . true .
C copy [..][..] to gelly
call rdpos ( cdum , cdum )
call rdpos ( cdum , cdum )
goto 23090
23089 continue
if(.not.( ch .eq. 105 ))goto 23091
C S(I ?
call garbs ( 0 )
C yes
call kgi ( intens )
C parse I spec
if(.not.( intens .ne. prmwop ( 10 ) .and. intens .ne. 8 ))goto 230
*93
prmwop ( 10 ) = intens
tmpwop ( 10 ) = intens
xgel = 127 + 10
call gel2 ( xgel , intens )
23093 continue
goto 23092
23091 continue
if(.not.( ch .eq. 110 ))goto 23095
C S(N ?
call garbs ( 1 )
C start Garbgel
call gel2 ( 40 , 78 )
gcgel = . true .
C copy number to gelly
call kgnum ( cdum )
C parse number
goto 23096
23095 continue
if(.not.( ch .eq. 116 ))goto 23097
C S(T ?
call garbs ( 1 )
C start Garbgel
call gel2 ( 40 , 84 )
gcgel = . true .
C copy number to gelly
call kgnum ( cdum )
C parse number
goto 23098
23097 continue
if(.not.( ch .eq. 119 ))goto 23099
C S(W ?
call garbs ( 0 )
C yes
call scantw
C temp wrt opts
goto 23100
23099 continue
if(.not.( ch .ne. 44 ))goto 23101
C unknown option
call imerr ( 12 )
C signal error
call cfind ( 41 )
C skip to next )
goto 23080
23101 continue
23100 continue
23098 continue
23096 continue
23092 continue
23090 continue
23086 continue
23084 continue
if(.not.( gcgel ))goto 23103
C was I creating Garbgel?
call gel1 ( 41 )
C yes, tie off opts
gcgel = . false .
C turn copying off
23103 continue
23079 goto 23078
23080 continue
goto 23077
23076 continue
if(.not.( ch .ne. 59 ))goto 23105
call imerr ( 12 )
23105 continue
23077 continue
C not S( or S;
23070 goto 23069
23071 continue
call putbak ( ch )
C put back unwanted char
call garbs ( 0 )
C close Garbgel
C if Erase option seen, copy temporary wops to permanent wops
C (Another goodie from the VK100 microcode)
if(.not.( erasfl ))goto 23107
call copywo ( tmpwop , prmwop , 10 )
23107 continue
end
C garbs - open S Garbgel (i.e., output Garbgel, LetS), or
C close S Garbgel (i.e., output Eos)
C Won't open if already open or close if already closed
subroutine garbs ( fnc )
integer fnc
C 0 = close, 1 = open
integer gel1 , sstart
C sstart remembers gel index of string
integer state
C current state (0 = closed, 1 = open)
data state / 0 /
C initially closed
if(.not.( fnc .ne. 0 .and. state .eq. 0 ))goto 23109
C want to open?
call gel1 ( ( - 1 ) )
C yes, do it
sstart = gel1 ( 83 )
C remember start of string
state = 1
C set state = open
23109 continue
if(.not.( fnc .eq. 0 .and. state .ne. 0 ))goto 23111
C want to close?
call gel1 ( 0 )
C yes, tie off Garbgel
call pckgel ( sstart )
C pack string in gel vector
state = 0
C set state = closed
23111 continue
end