Trailing-Edge
-
PDP-10 Archives
-
BB-K818A-BM_1981
-
sources/icmdt.for
There are no other files named icmdt.for in the archive.
C icmdt> ReGIS input -- parse "T" command (text)
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 cmdt - process "T" command
subroutine cmdt
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
integer strx , stry
integer ti
C tch allocation pointer
integer tch ( 128 )
common / ctext / strx , stry , ti , tch
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 tram> COMMON parameters set by T (text) command
C Note: rmul and cmul conform to the VK100 microcode definitions
C thus the M option is parsed as M[cmul,rmul]
C size of tram vector
logical tspflg
C .true. if [+-xspac,+-yspac] seen
integer tramsv ( 9 )
C tram copied here by T(B); copied back by T(E)
integer tram ( 9 )
C vector that contains all the T-ram stuff
integer rmul , cmul
C row, column multiplier
integer rsize , csize
C row, column size
integer xtchg , ytchg
C xspac and yspac
integer alphab
C alphabet (0 to 3)
integer slant
C italic slant (-45 to +45)
integer trdir
C rotation angle / 45 (0 to 7)
equivalence ( tram ( 1 ) , rmul )
equivalence ( tram ( 2 ) , cmul )
equivalence ( tram ( 3 ) , rsize )
equivalence ( tram ( 4 ) , csize )
equivalence ( tram ( 5 ) , xtchg )
equivalence ( tram ( 6 ) , ytchg )
equivalence ( tram ( 7 ) , alphab )
equivalence ( tram ( 8 ) , slant )
equivalence ( tram ( 9 ) , trdir )
common / trcom / tspflg , tramsv , tram
integer a1 , a2 , ch , ch1 , dir , dum , eat1 , gel1 , gel2 , geln
* , i , kterm , mag , pv , rdpos
integer txsav , tysav
C where to go if Return seen in text string
tspflg = . false .
C no explicit spacing yet
C scan next element of T command, one of:
C pixel vector (0-7)
C [+-xspac,+-yspac]
C (options)
C 'text'
C "text"
continue
23000 continue
call gnbc ( ch )
C get 1st character
if(.not.( kterm ( ch ) .ne. 0 ))goto 23003
C end of T command?
call putbak ( ch )
C yes, put it back
goto 23002
C wrap up T command
23003 continue
pv = ch - 48
if(.not.( pv .ge. 0 .and. pv .le. 7 ))goto 23005
C pixel vector (0-7)
if(.not.( pv .ne. 2 .and. pv .ne. 6 ))goto 23007
C moving in X
dir = trdir
C +X
if(.not.( pv .ge. 3 .and. pv .le. 5 ))goto 23009
C -X
dir = dir + 4
dir = mod ( dir , 8 )
23009 continue
mag = rsize / 2
call pvmove ( dir , mag , a1 , a2 )
xpos = xpos + a1
ypos = ypos + a2
23007 continue
if(.not.( pv .ne. 0 .and. pv .ne. 4 ))goto 23011
C moving in Y
dir = trdir + 6
C + 270 degrees
if(.not.( pv .lt. 4 ))goto 23013
dir = dir + 4
23013 continue
C -Y
dir = mod ( dir , 8 )
mag = csize / 2
call pvmove ( dir , mag , a1 , a2 )
xpos = xpos + a1
ypos = ypos + a2
23011 continue
goto 23006
23005 continue
if(.not.( ch .eq. 91 ))goto 23015
C [
call putbak ( ch )
C replace [ for rdpos
a1 = 0
a2 = 0
if(.not.( rdpos ( a1 , a2 ) .gt. 0 ))goto 23017
C valid [] parsed?
xtchg = a1
ytchg = a2
C yes, set new spacing
tspflg = . true .
C explicit-spacing seen
23017 continue
goto 23016
23015 continue
if(.not.( ch .eq. 39 .or. ch .eq. 34 ))goto 23019
C quoted string
call ramtop
C convert T-ram to gelly
ti = 1
C index into tch
dum = gel1 ( 7 )
C create Textgel
dum = gel2 ( xpos , ypos )
C starting coordinates
txsav = xpos
tysav = ypos
C save current X and Y
continue
23021 if(.not.( eat1 ( ch , ch1 ) .gt. 0 ))goto 23022
C get next character
C dum = gel1(ch1) #copy char to gelly
if(.not.( ti .lt. 128 - 1 ))goto 23023
tch ( ti ) = ch1
C save char
ti = ti + 1
23023 continue
if(.not.( ch1 .ge. 32 .or. ch1 .eq. 9 ))goto 23025
C spacing type?
C normal spacing
xpos = xpos + xtchg
C update X
ypos = ypos + ytchg
C update Y
goto 23026
23025 continue
C special spacing
if(.not.( ch1 .eq. 8 ))goto 23027
xpos = xpos - xtchg
C update X
ypos = ypos - ytchg
C update Y
goto 23028
23027 continue
if(.not.( ch1 .eq. 13 ))goto 23029
xpos = txsav
ypos = tysav
goto 23030
23029 continue
if(.not.( ch1 .eq. 10 ))goto 23031
i = trdir + 6
C add 270 degrees
i = mod ( i , 8 )
call pvmove ( i , csize , a1 , a2 )
C adjust current X and Y
xpos = xpos + a1
ypos = ypos + a2
C adjust start-of-line X and Y
txsav = txsav + a1
tysav = tysav + a2
C else no action for this character
goto 23032
23031 continue
ti = ti - 1
23032 continue
23030 continue
23028 continue
C delete from str
23026 continue
goto 23021
23022 continue
tch ( ti ) = 0
C tie off the Textgel
call cpystr ( tch , gel ( geln ( ti ) ) )
C copy to allocated gels
goto 23020
23019 continue
if(.not.( ch .eq. 40 ))goto 23033
C option list?
call cmdtop
C yes, process it
goto 23034
23033 continue
call imerr ( 16 )
23034 continue
23020 continue
23016 continue
23006 continue
C not legal T material
23001 goto 23000
23002 continue
end
C cmdtop - process (optionlist) for T command; assumes ( has been parsed
subroutine cmdtop
C tram> COMMON parameters set by T (text) command
C Note: rmul and cmul conform to the VK100 microcode definitions
C thus the M option is parsed as M[cmul,rmul]
C size of tram vector
logical tspflg
C .true. if [+-xspac,+-yspac] seen
integer tramsv ( 9 )
C tram copied here by T(B); copied back by T(E)
integer tram ( 9 )
C vector that contains all the T-ram stuff
integer rmul , cmul
C row, column multiplier
integer rsize , csize
C row, column size
integer xtchg , ytchg
C xspac and yspac
integer alphab
C alphabet (0 to 3)
integer slant
C italic slant (-45 to +45)
integer trdir
C rotation angle / 45 (0 to 7)
equivalence ( tram ( 1 ) , rmul )
equivalence ( tram ( 2 ) , cmul )
equivalence ( tram ( 3 ) , rsize )
equivalence ( tram ( 4 ) , csize )
equivalence ( tram ( 5 ) , xtchg )
equivalence ( tram ( 6 ) , ytchg )
equivalence ( tram ( 7 ) , alphab )
equivalence ( tram ( 8 ) , slant )
equivalence ( tram ( 9 ) , trdir )
common / trcom / tspflg , tramsv , tram
integer a1 , a2 , angpv , ch , i , kgnum , kterm , rdpos
continue
23035 continue
call gnbc ( ch )
C get next option
if(.not.( ch .eq. 41 .or. ch .eq. 59 ))goto 23038
goto 23037
C end of options
23038 continue
a1 = 0
a2 = 0
C init for M, S
if(.not.( ch .eq. 97 ))goto 23040
C Alphabet
i = kgnum ( alphab )
goto 23041
23040 continue
if(.not.( ch .eq. 98 ))goto 23042
C Begin
call copywo ( tram , tramsv , 9 )
C save T params
goto 23043
23042 continue
if(.not.( ch .eq. 100 ))goto 23044
C Direction
if(.not.( kgnum ( i ) .gt. 0 ))goto 23046
C parsed something?
trdir = angpv ( i )
23046 continue
C yes, get 0-7
goto 23045
23044 continue
if(.not.( ch .eq. 101 ))goto 23048
C End
call copywo ( tramsv , tram , 9 )
C restore params
goto 23049
23048 continue
if(.not.( ch .eq. 104 ))goto 23050
C Height
if(.not.( kgnum ( i ) .gt. 0 ))goto 23052
C parsed a number?
if(.not.( i .gt. 0 ))goto 23054
C yes, is it positive?
rmul = i
C yes
csize = i * 10
23054 continue
23052 continue
goto 23051
23050 continue
if(.not.( ch .eq. 105 ))goto 23056
C Italic
i = kgnum ( slant )
C parse a number
if(.not.( slant .lt. - 45 ))goto 23058
slant = - 45
23058 continue
C impose limits
if(.not.( slant .gt. 45 ))goto 23060
slant = 45
23060 continue
goto 23057
23056 continue
if(.not.( ch .eq. 109 ))goto 23062
C Multiply
call gnbc ( ch )
call putbak ( ch )
C peek
if(.not.( ch .eq. 91 ))goto 23064
C M[ ?
if(.not.( rdpos ( a1 , a2 ) .gt. 0 ))goto 23066
C get [cmul,rmul]
if(.not.( a1 .gt. 0 ))goto 23068
cmul = a1
23068 continue
if(.not.( a2 .gt. 0 ))goto 23070
rmul = a2
23070 continue
23066 continue
23064 continue
goto 23063
23062 continue
if(.not.( ch .eq. 115 ))goto 23072
C Size
continue
23074 continue
call gnbc ( ch )
call putbak ( ch )
C peek
if(.not.( kterm ( ch ) .ne. 0 ))goto 23077
goto 23076
C end of T(S
23077 continue
if(.not.( ch .eq. 91 ))goto 23079
C S[rsize,csize] ?
if(.not.( rdpos ( a1 , a2 ) .gt. 0 ))goto 23081
C yes
if(.not.( a1 .gt. 0 ))goto 23083
rsize = a1
23083 continue
if(.not.( a2 .gt. 0 ))goto 23085
csize = a2
23085 continue
23081 continue
goto 23076
goto 23080
23079 continue
C not S[rsize,csize]
call skpbal ( 0 )
if(.not.( kgnum ( i ) .le. 0 ))goto 23087
C Snumber ?
C no, probably something bogus
if(.not.( ch .ne. 44 ))goto 23089
call imerr ( 16 )
23089 continue
call gnbc ( ch )
C skip this character
goto 23075
C continue parsing T(S
23087 continue
if(.not.( i .lt. 0 ))goto 23091
goto 23075
C yes, reject negative
23091 continue
if(.not.( i .eq. 0 ))goto 23093
cmul = 1
rmul = 1
goto 23094
23093 continue
cmul = i
rmul = ( i * 3 + 1 ) / 2
23094 continue
rsize = cmul * 9
csize = rmul * 10
if(.not.( . not . tspflg ))goto 23095
C explicit [xspac,yspac]?
call pvmove ( trdir , rsize , xtchg , ytchg )
23095 continue
C no
goto 23076
23080 continue
23075 goto 23074
23076 continue
goto 23073
23072 continue
if(.not.( ch .eq. 119 ))goto 23097
C Writing options
call scantw
goto 23098
23097 continue
if(.not.( ch .ne. 44 ))goto 23099
C comma?
call imerr ( 16 )
C no, signal bad T option
call cfind ( 41 )
C skip to ) or Sync
goto 23037
23099 continue
23098 continue
23073 continue
23063 continue
23057 continue
23051 continue
23049 continue
23045 continue
23043 continue
23041 continue
23036 goto 23035
23037 continue
end
C ramtop - convert T-ram values into text options and then merge
C the updated text options into gelly
subroutine ramtop
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 tram> COMMON parameters set by T (text) command
C Note: rmul and cmul conform to the VK100 microcode definitions
C thus the M option is parsed as M[cmul,rmul]
C size of tram vector
logical tspflg
C .true. if [+-xspac,+-yspac] seen
integer tramsv ( 9 )
C tram copied here by T(B); copied back by T(E)
integer tram ( 9 )
C vector that contains all the T-ram stuff
integer rmul , cmul
C row, column multiplier
integer rsize , csize
C row, column size
integer xtchg , ytchg
C xspac and yspac
integer alphab
C alphabet (0 to 3)
integer slant
C italic slant (-45 to +45)
integer trdir
C rotation angle / 45 (0 to 7)
equivalence ( tram ( 1 ) , rmul )
equivalence ( tram ( 2 ) , cmul )
equivalence ( tram ( 3 ) , rsize )
equivalence ( tram ( 4 ) , csize )
equivalence ( tram ( 5 ) , xtchg )
equivalence ( tram ( 6 ) , ytchg )
equivalence ( tram ( 7 ) , alphab )
equivalence ( tram ( 8 ) , slant )
equivalence ( tram ( 9 ) , trdir )
common / trcom / tspflg , tramsv , tram
integer wrktop ( 6 )
C converted T-ram goes here
integer i
wrktop ( 1 ) = alphab
C alphabet (A)
wrktop ( 5 ) = slant
C slant (I)
wrktop ( 6 ) = trdir * 45
C rotation (D)
wrktop ( 3 ) = ( csize + 9 ) / 10
wrktop ( 4 ) = 0
C assume text (9)
if(.not.( rsize .eq. cmul * 8 ))goto 23101
wrktop ( 4 ) = 1
23101 continue
C nope, it's mosaic (8)
i = 9 - wrktop ( 4 )
C get 8 or 9
wrktop ( 2 ) = ( rsize + i - 1 ) / i
C width
call mrgopt ( wrktop , prmtop , 6 , 255 )
C merge into perm topts
end
C topram - convert toptions (in prmtop) to T-ram values (in tram)
subroutine topram
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 tram> COMMON parameters set by T (text) command
C Note: rmul and cmul conform to the VK100 microcode definitions
C thus the M option is parsed as M[cmul,rmul]
C size of tram vector
logical tspflg
C .true. if [+-xspac,+-yspac] seen
integer tramsv ( 9 )
C tram copied here by T(B); copied back by T(E)
integer tram ( 9 )
C vector that contains all the T-ram stuff
integer rmul , cmul
C row, column multiplier
integer rsize , csize
C row, column size
integer xtchg , ytchg
C xspac and yspac
integer alphab
C alphabet (0 to 3)
integer slant
C italic slant (-45 to +45)
integer trdir
C rotation angle / 45 (0 to 7)
equivalence ( tram ( 1 ) , rmul )
equivalence ( tram ( 2 ) , cmul )
equivalence ( tram ( 3 ) , rsize )
equivalence ( tram ( 4 ) , csize )
equivalence ( tram ( 5 ) , xtchg )
equivalence ( tram ( 6 ) , ytchg )
equivalence ( tram ( 7 ) , alphab )
equivalence ( tram ( 8 ) , slant )
equivalence ( tram ( 9 ) , trdir )
common / trcom / tspflg , tramsv , tram
integer angpv
alphab = prmtop ( 1 )
C alphabat (A)
slant = prmtop ( 5 )
C slant (I)
trdir = angpv ( prmtop ( 6 ) )
C text direction (D)
rmul = prmtop ( 3 )
C M[cmul,rmul]
cmul = prmtop ( 2 )
rsize = ( 9 - prmtop ( 4 ) ) * cmul
C S[rsize,csize]
csize = 10 * rmul
call pvmove ( trdir , rsize , xtchg , ytchg )
C [+-xspac,+-yspac]
end