Trailing-Edge
-
PDP-10 Archives
-
BB-K829A-BM_1981
-
sources/gn.for
There are no other files named gn.for in the archive.
C gn> More command drivers
C RTA 10/24/80 Call loadf to load font name into terminal
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 copyright notice
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 ** Symbolic definitions **
C data types
C define character byte
C max string storage
C max string index storage
C important string indices (see gs module)
C cdisp - function codes
C coord - axis codes
C cpystr - option codes
C da1 - function codes
C da2 - function codes
C dcs - function codes
C ffopen - modes
C frtyp - record types
C (careful - used in computed goto's)
C ftran - function codes
C undo - function codes
C utty - function codes
C codes returned by keypad function
C character types
C composites
C CTKEY = CTALPHA + CTNUM + CTHYPH
C CTFILE = CTALPHA + CTNUM + CTDOT + CTSLASH + CTCOLON
C colors - temporarily all white
C screen dimensions (pixels)
C displays in area 3
C must match showtab in gm
C maximum mosaic dimensions
C dimensions of mosaic display window
C quan to subtract from char to get fmat/fmatc subscript
C lowest, highest, number of characters in VK100 font
C number of loadable fonts in VK100
C character definitions
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C character definitions
C logical file number (lfn) definitions
C SNRL1 = characters SNRL2 = into-characters SNRL3 = mapping
C all are 97 characters long
C @142 xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
C @143 xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
C @144 xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
C fcscan - perform scanning for file-access commands
C sno: string # of option table
C returns -1 if error detected, else 0
integer function fcscan ( sno )
implicit integer ( a - z )
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gncom>
logical allc , fnp
common / gncom / allc , fnp , transf , x1 , x2 , x3
C .false. iff "characters" or "into-characters" present
C .true. iff filename present in command line
C transformation code
C xn = sx(SNRLn)
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
fcscan = - 1
C assume failed
allc = . true .
C assume reading all characters
transf = 0
C 0 normal, 1 reverse, 2 set, 3 clear, 4 complement
mno = 0
C # of transformations in cmd line (for warning user)
fnp = . false .
C flag for filespec present in comamnd line
x1 = sx ( 142 )
x2 = sx ( 143 )
x3 = sx ( 144 ) - 32
C handy values
sv ( x1 ) = 0
C characters
sv ( x2 ) = 0
C into-characters
continue
23000 if(.not.( chkeol ( 0 ) .eq. 0 ))goto 23001
C parse until eol hit
kno = pkey ( sno )
C get keyword
if(.not.( kno .eq. - 1 ))goto 23002
return
23002 continue
C bad parse
if(.not.( kno .eq. 0 .or. kno .eq. 1 ))goto 23004
allc = . false .
23004 continue
C not all chars
if(.not.( kno .eq. 0 ))goto 23006
if(.not.( pclist ( 142 ) .ne. 0 ))goto 23008
return
23008 continue
23006 continue
C characters
if(.not.( kno .eq. 1 ))goto 23010
if(.not.( pclist ( 143 ) .ne. 0 ))goto 23012
return
23012 continue
23010 continue
C into-characters
if(.not.( kno .eq. 2 ))goto 23014
C file
call pskip ( 4 )
C skip blanks before filespec
forg = pptr
C remember where filespec starts
if(.not.( pflnm ( pptr , 0 , 0 ) .lt. 0 ))goto 23016
return
23016 continue
C parse filespec
fnp = . true .
C remember filespec present
23014 continue
if(.not.( kno .ge. 11 .and. kno .le. 14 ))goto 23018
C reverse,set,clear,complement
mno = mno + 1
C count # of transformations
transf = kno - 10
C remember transformation
23018 continue
goto 23000
23001 continue
if(.not.( mno .gt. 1 ))goto 23020
call pdiag ( 134 )
C @134 More than one transformation specified - using last one
23020 continue
if(.not.( fnp ))goto 23022
call pflnm ( forg , 5 , 57 )
C copy filespec into SNFIL
C parsing done, now work out character lists
23022 continue
i = 0
if(.not.( sv ( x1 ) .eq. 0 ))goto 23024
if(.not.( sv ( x2 ) .eq. 0 ))goto 23026
C neither specified,
continue
23028 if(.not.( i .lt. 95 ))goto 23029
C so set both to all
sv ( x1 + i ) = i + 32
sv ( x2 + i ) = i + 32
i = i + 1
goto 23028
23029 continue
sv ( x1 + 95 ) = 0
sv ( x2 + 95 ) = 0
C tie 'em off
goto 23027
23026 continue
continue
23030 continue
C only into-characters
ch = sv ( x2 + i )
sv ( x1 + i ) = ch
C copy into-chars to chars
i = i + 1
23031 if(.not.( ch .eq. 0 ))goto 23030
23032 continue
23027 continue
goto 23025
23024 continue
if(.not.( sv ( x2 ) .eq. 0 ))goto 23033
continue
23035 continue
C only characters
ch = sv ( x1 + i )
sv ( x2 + i ) = ch
C copy chars to into-chars
i = i + 1
23036 if(.not.( ch .eq. 0 ))goto 23035
23037 continue
23033 continue
23025 continue
C if both specified, no action
C SNRL3 indexed by char gives you the corresponding into-char
continue
i = 126
23038 if(.not.(i.ge.32))goto 23040
sv ( x3 + i ) = 0
23039 i=i-1
goto 23038
23040 continue
C clear SNRL3
i = 0
continue
23041 if(.not.( . true . ))goto 23042
ch1 = sv ( x1 + i )
ch2 = sv ( x2 + i )
C get char, into-char
if(.not.( ch1 .eq. 0 .or. ch2 .eq. 0 ))goto 23043
goto 23042
C exit at end of either list
23043 continue
sv ( x3 + ch1 ) = ch2
C create mapping
i = i + 1
goto 23041
23042 continue
fcscan = 0
C success
end
C frtyp - determine type of record read from file; record in SNUST
C returns:
C RTUNR unidentified
C RTDEF character definition
C RTFNM font-name
C RTMOS mosaic-row
integer function frtyp ( sno )
implicit integer ( a - z )
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
integer sp
integer c1 , c2 , c3
frtyp = 1
C assume unidentified record
c1 = sv ( iuptr )
c2 = sv ( iuptr + 1 )
c3 = sv ( iuptr + 2 )
if(.not.( c1 .eq. 108 ))goto 23045
if(.not.( c2 .eq. 40 .and. c3 .eq. 97 ))goto 23047
frtyp = 3
goto 23048
23047 continue
if(.not.( c2 .eq. 34 .or. c2 .eq. 39 ))goto 23049
frtyp = 2
23049 continue
23048 continue
goto 23046
23045 continue
if(.not.( c1 .eq. 59 .and. c2 .eq. 34 ))goto 23051
frtyp = 4
23051 continue
23046 continue
end
C ftran - transfer stuff between file and program memory
C func: 1) FTMOS - write mosaic
C 2) FTFNM - write font name
C 3) else func specifies a character definition in fmat
C arg: for case 3 above, destination character in file
subroutine ftran ( func , arg )
implicit integer ( a - z )
C gccom>
integer mosmat ( 10 , 10 ) , omosmt ( 10 , 10 )
integer fmat ( 96 , 10 ) , fmatc ( 96 )
logical cdcec , rdmos
common / gccom / a3 , a3x , cdch ( 7 ) , cdcec ( 7 ) , cdrot ( 7
*) , cdsiz ( 7 ) , cdsln ( 7 ) , dinitf , dnrow , dncol , dorow , d
*ocol , edchar , fmat , fmatc , mosmat , omosmt , rdmos , rmul , cm
*ul , rsize , csize , sfont , uprow , upcol , wcol , wcol8 , wrow ,
* wrow10
C handle of display currently in area 3
C >0 no action, =0 regenerate area 3, <0 update area 3
C characters being displayed in area 3
C .true. = always shows currently-edited character
C height of window in characters, cells
C sfont may be changed ONLY by calling setfnt(new-font-#)
C fmat: contains the bit definitions for all characters in the font.
C The row is given by <character>-FMOFF, such that Space is
C defined in fmat(2,*), ! in fmat(3,*), etc. The row fmat(1,*)
C always contains all zeros (used by ffcreate). Each column of
C fmat contains 8 bits that define 1 row of the character.
C fmatc: fmatc(x) is parallel to fmat(x,*). A non-zero fmatc entry
C indicates that the definition of the respective character
C has changed, and that the dupd routine must update the
C screen accordingly. fmatc(1) is unused.
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
uptr = iuptr
C point at beginning of SNUST
if(.not.( func .lt. 10 ))goto 23053
goto ( 201 , 202 ) , func
C writing a character's definition
23053 continue
i = 34
if(.not.( arg .eq. 34 ))goto 23055
i = 39
23055 continue
C select quote
call putu ( 108 )
call putu ( i )
call putu ( arg )
call putu ( i )
call defhex ( func , uptr )
C get hex definition of character
call putu ( 0 )
C tie it off
call ffwrt ( 2 )
C write record to file
return
C writing mosaic
201 continue
ir = 1
23057 if(.not.(ir.le.10))goto 23059
uptr = iuptr
C point to start of SNUST
call putu ( 59 )
call putu ( 34 )
continue
ic = 1
23060 if(.not.(ic.le.10))goto 23062
ch = mosmat ( ir , ic )
call putuq ( ch )
C tack on this character
23061 ic=ic+1
goto 23060
23062 continue
call putu ( 34 )
call putu ( 0 )
call ffwrt ( 2 )
C write record to file
23058 ir=ir+1
goto 23057
23059 continue
return
C writing font file name
202 call cpystr ( 70 , 0 )
C @70 l(a"
pfn = sx ( 9 )
C get index to font name string
continue
23063 if(.not.( . true . ))goto 23064
ch = sv ( pfn )
pfn = pfn + 1
C get char
if(.not.( ch .eq. 0 ))goto 23065
goto 23064
C end of string
23065 continue
call putuq ( ch )
goto 23063
23064 continue
call putu ( 34 )
call putu ( 41 )
call putu ( 0 )
call ffwrt ( 2 )
C write record
return
end
C mospec - process "mosaic" command - lets the user specify the
C position of the window or the contents of the mosaic
subroutine mospec
implicit integer ( a - z )
C gccom>
integer mosmat ( 10 , 10 ) , omosmt ( 10 , 10 )
integer fmat ( 96 , 10 ) , fmatc ( 96 )
logical cdcec , rdmos
common / gccom / a3 , a3x , cdch ( 7 ) , cdcec ( 7 ) , cdrot ( 7
*) , cdsiz ( 7 ) , cdsln ( 7 ) , dinitf , dnrow , dncol , dorow , d
*ocol , edchar , fmat , fmatc , mosmat , omosmt , rdmos , rmul , cm
*ul , rsize , csize , sfont , uprow , upcol , wcol , wcol8 , wrow ,
* wrow10
C handle of display currently in area 3
C >0 no action, =0 regenerate area 3, <0 update area 3
C characters being displayed in area 3
C .true. = always shows currently-edited character
C height of window in characters, cells
C sfont may be changed ONLY by calling setfnt(new-font-#)
C fmat: contains the bit definitions for all characters in the font.
C The row is given by <character>-FMOFF, such that Space is
C defined in fmat(2,*), ! in fmat(3,*), etc. The row fmat(1,*)
C always contains all zeros (used by ffcreate). Each column of
C fmat contains 8 bits that define 1 row of the character.
C fmatc: fmatc(x) is parallel to fmat(x,*). A non-zero fmatc entry
C indicates that the definition of the respective character
C has changed, and that the dupd routine must update the
C screen accordingly. fmatc(1) is unused.
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
data msrow , mscol / 1 , 1 /
C cursor row,col in mosaic
if(.not.( peol ( 0 ) .ne. 0 ))goto 23067
return
23067 continue
C check for trash after command
call seta3 ( 2 )
C show mosaic map in area 3
call lmode ( 1 )
C set VK100 SC1
continue
23069 continue
C loop until user hits CR
call dupd
C update display
call postcm ( msrow , mscol )
C position text-mode cursor on mosaic
call read1 ( 0 )
C read character from VK100
ch = sv ( pptr )
C get character
cmd = keypad ( 0 )
C keypad character typed?
if(.not.( cmd .lt. 0 ))goto 23072
C no, must be changing mosaic
if(.not.( ch .ge. 32 ))goto 23074
mosmat ( msrow , mscol ) = ch
23074 continue
23072 continue
if(.not.( cmd .ge. 1 .and. cmd .le. 9 ))goto 23076
if(.not.( cmd .eq. 5 ))goto 23078
C set window position
docol = max0 ( mscol - 1 , 1 )
docol = min0 ( docol , 10 - 3 + 1 )
dorow = max0 ( msrow - 1 , 1 )
dorow = min0 ( dorow , 10 - 3 + 1 )
call stcwcn ( cwcn )
C update cmrow, etc.
goto 23079
23078 continue
C move cursor
msrow = mod ( msrow + 10 - ( cmd - 1 ) / 3 , 10 ) + 1
mscol = mod ( mscol + 10 - 2 + mod ( cmd - 1 , 3 ) , 10 ) + 1
23079 continue
23076 continue
23070 if(.not.( cmd .eq. 22 ))goto 23069
23071 continue
call lmode ( 1 )
C restore SC0
end
C rdcmd - process read command
subroutine rdcmd
implicit integer ( a - z )
C gccom>
integer mosmat ( 10 , 10 ) , omosmt ( 10 , 10 )
integer fmat ( 96 , 10 ) , fmatc ( 96 )
logical cdcec , rdmos
common / gccom / a3 , a3x , cdch ( 7 ) , cdcec ( 7 ) , cdrot ( 7
*) , cdsiz ( 7 ) , cdsln ( 7 ) , dinitf , dnrow , dncol , dorow , d
*ocol , edchar , fmat , fmatc , mosmat , omosmt , rdmos , rmul , cm
*ul , rsize , csize , sfont , uprow , upcol , wcol , wcol8 , wrow ,
* wrow10
C handle of display currently in area 3
C >0 no action, =0 regenerate area 3, <0 update area 3
C characters being displayed in area 3
C .true. = always shows currently-edited character
C height of window in characters, cells
C sfont may be changed ONLY by calling setfnt(new-font-#)
C fmat: contains the bit definitions for all characters in the font.
C The row is given by <character>-FMOFF, such that Space is
C defined in fmat(2,*), ! in fmat(3,*), etc. The row fmat(1,*)
C always contains all zeros (used by ffcreate). Each column of
C fmat contains 8 bits that define 1 row of the character.
C fmatc: fmatc(x) is parallel to fmat(x,*). A non-zero fmatc entry
C indicates that the definition of the respective character
C has changed, and that the dupd routine must update the
C screen accordingly. fmatc(1) is unused.
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gncom>
logical allc , fnp
common / gncom / allc , fnp , transf , x1 , x2 , x3
C .false. iff "characters" or "into-characters" present
C .true. iff filename present in command line
C transformation code
C xn = sx(SNRLn)
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
logical indef
if(.not.( fcscan ( 141 ) .ne. 0 ))goto 23080
return
C scan keyword list and other stuff
C @141 00characters "CHAR CHAR ..."^
C 01into-characters "CHAR CHAR ..."^
C 02file FILESPEC^
C 11reverse (reads complement of file into font)^
C 12set (font bits from 1-bits in file)^
C 13clear (font bits from 1-bits in file)^
C 14complement (font bits from 1-bits in file)
C get the font file name if I don't have one already
23080 continue
if(.not.( sv ( sx ( 5 ) ) .eq. 0 ))goto 23082
C have a filename?
continue
23084 if(.not.( . true . ))goto 23085
C nope
call prdtty ( 137 )
C @137 Name of font file: \b
if(.not.( chkeol ( 0 ) .ne. 0 ))goto 23086
return
23086 continue
C no name given
forg = pptr
C remember start of filespec
if(.not.( pflnm ( pptr , 0 , 0 ) .ge. 0 ))goto 23088
C filename parsed ok?
if(.not.( peol ( 0 ) .eq. 0 ))goto 23090
goto 23085
C yes, break on eol
23090 continue
23088 continue
C bad parse, repeat query
goto 23084
23085 continue
call pflnm ( forg , 5 , 57 )
C @57 .fnt
C NOTE: 57 is used elsewhere!
C get the file open
23082 continue
if(.not.( ffopen ( 1 , 5 , 0 ) .ne. 0 ))goto 23092
C open file for read
call pdiag ( 145 )
C @145 Cannot open file %f
return
C scan file extracting requested characters
23092 continue
mosrow = 0
C init mosaic row #
continue
23094 if(.not.( ffread ( 1 , 0 ) .ne. 0 ))goto 23095
C loop until eof
goto ( 201 , 202 , 203 , 204 ) , frtyp ( 0 )
C identify record and dispatch
C font name
203 if(.not.( . not . allc ))goto 23096
goto 23094
C do only if loading entire font
23096 continue
i = 0
C index to SNFNM
uptr = iuptr + 4
C l(a"xxxxxx")
continue
23098 continue
C loop once per character in name
ch = gscq ( uptr )
C get char
sv ( sx ( 9 ) + i ) = ch
C move to SNFNM
i = i + 1
23099 if(.not.( ch .eq. 0 .or. i .eq. 10 ))goto 23098
23100 continue
call loadf
C load font name into VK100
call da1 ( 4 )
C update font name in area 1
goto 23094
C done with this record
C mosaic row
204 if(.not.( . not . allc ))goto 23101
goto 23094
C do only if loading entire font
23101 continue
rdmos = . true .
C remember mosaic-read for dupd
mosrow = mosrow + 1
C next row
if(.not.( mosrow .gt. 10 ))goto 23103
goto 23094
C discard extra rows
23103 continue
uptr = iuptr + 2
C ;"xxxxxxxxxx"
continue
i = 1
23105 if(.not.(i.le.10))goto 23107
C loop thru chars in row
ch = gscq ( uptr )
C get character
if(.not.( ch .ge. 32 ))goto 23108
mosmat ( mosrow , i ) = ch
23108 continue
23106 i=i+1
goto 23105
23107 continue
goto 23094
C done with this record
C character-definition record
202 filen = sv ( iuptr + 2 )
C get character from record
fontn = sv ( x3 + filen ) - 30
C get corresponding into-character
if(.not.( fontn .lt. 0 ))goto 23110
goto 23094
C skip it if the user doesn't want it
23110 continue
indef = . true .
C end-of-definition not seen yet
continue
i = 1
23112 if(.not.(i.le.10))goto 23114
C loop once per row
ni = sv ( iuptr + i * 2 + 2 ) - 48
C get 1st hex digit
if(.not.( ni .eq. 59 - 48 ))goto 23115
indef = . false .
23115 continue
filech = 0
C assume end-of-def
if(.not.( indef ))goto 23117
C do processing if ";" not seen yet
if(.not.( ni .gt. 9 ))goto 23119
ni = ni + 48 - 65 + 10
23119 continue
filech = sv ( iuptr + i * 2 + 3 ) - 48
C get 2nd hex dig
if(.not.( filech .gt. 9 ))goto 23121
filech = filech + 48 - 65 + 10
23121 continue
filech = ni * 16 + filech
C merge them
23117 continue
fontch = fmat ( fontn , i )
goto ( 300 , 301 , 302 , 303 , 304 ) , transf + 1
300 fontch = filech
C no transformation (normal)
goto 399
301 fontch = ieor ( filech , 255 )
C reverse
goto 399
302 fontch = ior ( fontch , filech )
C set
goto 399
303 fontch = iand ( fontch , ieor ( filech , 255 ) )
C clear
goto 399
304 fontch = ieor ( fontch , filech )
C complement
C goto 399
399 fmat ( fontn , i ) = fontch
C store into font
23113 i=i+1
goto 23112
23114 continue
fmatc ( fontn ) = 1
C set definition-changed
201 continue
goto 23094
23095 continue
call ffcls ( 1 )
C close the file
end
C regcmd - process ReGIS command
C forms of command:
C ReGIS string -> stores string in memory
C ReGIS ? -> types string from memory
C ReGIS -> puts VK100 in graphics mode
C and then writes the string
C If any % characters appear in the string, the program will
C prompt the user for text to replace them.
subroutine regcmd
implicit integer ( a - z )
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
if(.not.( chkeol ( 0 ) .eq. 0 ))goto 23123
C something after command name
if(.not.( sv ( pptr ) .eq. 63 ))goto 23125
call dcs ( 4 )
call pr0 ( 7 )
C wants to see string
goto 23126
23125 continue
rp1 = sx ( 7 )
C wants to specify string
continue
23127 continue
sv ( rp1 ) = sv ( pptr )
C copy string to SNREG
rp1 = rp1 + 1
pptr = pptr + 1
23128 if(.not.( sv ( pptr - 1 ) .eq. 0 ))goto 23127
23129 continue
23126 continue
goto 23124
23123 continue
C nothing after command name
rp1 = sx ( 7 ) - 1
rp2 = iuptr
sv ( rp2 ) = 0
continue
23130 continue
C loop to xfer SNREG to SNUST
rp1 = rp1 + 1
if(.not.( sv ( rp1 ) .eq. 37 ))goto 23133
C % hit, do substitution
call prdtty ( 6 )
C prompt
continue
23135 if(.not.( . true . ))goto 23136
C append input to SNUST
if(.not.( sv ( pptr ) .eq. 0 ))goto 23137
goto 23136
C end of input
23137 continue
sv ( rp2 ) = sv ( pptr )
rp2 = rp2 + 1
pptr = pptr + 1
goto 23135
23136 continue
goto 23134
23133 continue
sv ( rp2 ) = sv ( rp1 )
C not %, just copy it
rp2 = rp2 + 1
C bump destination ptr
23134 continue
sv ( rp2 ) = 0
C keep a null at the end
23131 if(.not.( sv ( rp1 ) .eq. 0 ))goto 23130
23132 continue
call pdiag ( 6 )
C display final product in area 4
call regis ( 6 )
C send it in graphics mode
23124 continue
end
C wrtcmd - process write command
subroutine wrtcmd
implicit integer ( a - z )
C gccom>
integer mosmat ( 10 , 10 ) , omosmt ( 10 , 10 )
integer fmat ( 96 , 10 ) , fmatc ( 96 )
logical cdcec , rdmos
common / gccom / a3 , a3x , cdch ( 7 ) , cdcec ( 7 ) , cdrot ( 7
*) , cdsiz ( 7 ) , cdsln ( 7 ) , dinitf , dnrow , dncol , dorow , d
*ocol , edchar , fmat , fmatc , mosmat , omosmt , rdmos , rmul , cm
*ul , rsize , csize , sfont , uprow , upcol , wcol , wcol8 , wrow ,
* wrow10
C handle of display currently in area 3
C >0 no action, =0 regenerate area 3, <0 update area 3
C characters being displayed in area 3
C .true. = always shows currently-edited character
C height of window in characters, cells
C sfont may be changed ONLY by calling setfnt(new-font-#)
C fmat: contains the bit definitions for all characters in the font.
C The row is given by <character>-FMOFF, such that Space is
C defined in fmat(2,*), ! in fmat(3,*), etc. The row fmat(1,*)
C always contains all zeros (used by ffcreate). Each column of
C fmat contains 8 bits that define 1 row of the character.
C fmatc: fmatc(x) is parallel to fmat(x,*). A non-zero fmatc entry
C indicates that the definition of the respective character
C has changed, and that the dupd routine must update the
C screen accordingly. fmatc(1) is unused.
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gecom>
logical quitf
common / gecom / ccrow , cccol , cmrow , cmcol , cwcn , lmrow , l
*mcol , lwcn , quitf
C character row,col of cwcn
C mosaic row,col of cwcn
C wcn of current position in window
C mosaic row,col of lwcn
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gncom>
logical allc , fnp
common / gncom / allc , fnp , transf , x1 , x2 , x3
C .false. iff "characters" or "into-characters" present
C .true. iff filename present in command line
C transformation code
C xn = sx(SNRLn)
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
logical wrtfnm , wrtmos
C name of temp file #@91 cse.tmp
if(.not.( fcscan ( 148 ) .ne. 0 ))goto 23139
return
C parse command line
C note reversal of characters and into-characters; this causes RL3
C to contain fmat characters indexed by file character
C @148 01characters "CHAR CHAR ..."^
C 00into-characters "CHAR CHAR ..."^
C 02file FILESPEC
23139 continue
if(.not.( . not . fnp ))goto 23141
sv ( sx ( 5 ) ) = 0
C force user to give filespec
C command parsing done, open the input file
23141 continue
i = ffopen ( 1 , 5 , 0 )
C open file
if(.not.( i .eq. - 1 ))goto 23143
return
C can't get name
C if file already exists, request confirmation
23143 continue
if(.not.( i .eq. 0 ))goto 23145
C does file exist?
if(.not.( yn ( 63 ) .eq. 0 ))goto 23147
C yes, want to proceed?
C @63 The file exists - do you want to proceed?\b
call ffcls ( 1 )
C no, close input file
return
C open temp file for output
23147 continue
23145 continue
if(.not.( ffopen ( 2 , 91 , 2 ) .gt. 0 ))goto 23149
call pdiag ( 149 )
C @149 Cannot open temp file
call ffcls ( 1 )
C close input file
return
23149 continue
wrtfnm = . true .
wrtmos = . true .
C assume I want to write these
if(.not.( i .eq. 0 ))goto 23151
C have input file?
continue
23153 if(.not.( ffread ( 1 , 0 ) .ne. 0 ))goto 23154
C loop thru records of input file
goto ( 401 , 402 , 403 , 404 ) , frtyp ( 0 )
C identify record type
C character-definition record
402 filec = sv ( iuptr + 2 )
C get character being defined
i = sv ( x3 + filec )
C get RL3 entry for that char
if(.not.( i .eq. 0 ))goto 23155
goto 401
23155 continue
C not spec by user, just copy it
if(.not.( i .eq. 1 ))goto 23157
goto 23153
C duplicate, pitch it
23157 continue
call ftran ( i , filec )
C replace with char from fmat
sv ( x3 + filec ) = 1
C remember I wrote this one
goto 23153
C font-name record
403 wrtfnm = . false .
C don't write font-name later
if(.not.( . not . allc ))goto 23159
goto 401
23159 continue
C just copy it
call ftran ( 2 , 0 )
C replace it with current name
goto 23153
C mosaic-row
404 if(.not.( allc ))goto 23161
goto 23153
C replacing mosaic (done later)
23161 continue
wrtmos = . false .
C remember file has a mosaic
goto 401
C just copy record
C unidentified record
401 call ffwrt ( 2 )
C preserve it
goto 23153
23154 continue
call ffcls ( 1 )
C close input file
C end if-have-input-file
23151 continue
if(.not.( wrtfnm ))goto 23163
call ftran ( 2 , 0 )
23163 continue
C write font name if needed
if(.not.( wrtmos ))goto 23165
call ftran ( 1 , 0 )
C write mosaic if needed
C scan RL3 for any characters that the user wanted to write and
C didn't appear in the font file
23165 continue
continue
filec = 32
23167 if(.not.(filec.le.126))goto 23169
i = sv ( x3 + filec )
C get corresp fmat character
if(.not.( i .ge. 32 ))goto 23170
C char written yet?
if(.not.( allc .and. i .ne. 32 ))goto 23172
C no
i1 = i - 30
C convert for fmat access
continue
j = 1
23174 if(.not.(j.lt.10))goto 23176
if(.not.( fmat ( i1 , j ) .ne. 0 ))goto 23177
goto 500
23177 continue
23175 j=j+1
goto 23174
23176 continue
goto 23168
C no bits set in char, skip it
23172 continue
500 call ftran ( i , filec )
C write definition to file
23170 continue
23168 filec=filec+1
goto 23167
23169 continue
call ffcls ( 2 )
C close output file
if(.not.( ffrenm ( 91 , 5 ) .ne. 0 ))goto 23179
call pdiag ( 92 )
23179 continue
C @92 Cannot create file %f
quitf = . false .
C ok to quit now
end