Trailing-Edge
-
PDP-10 Archives
-
BB-K818A-BM_1981
-
sources/ichar.for
There are no other files named ichar.for in the archive.
C ichar> ReGIS input -- "Get-character-from-file" routines
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 Layering of "get-char" routines (with apologies for the complexity)
C From lowest-level to highest-level:
C
C getc: right from the file; Eof represented by -1 (Eof)
C gnc: get next char from
C 1. character that was put back
C 2. current macrograph being expanded
C 3. getc (if 1 and 2 fail)
C called by gxc and quoted-text parser
C gxc: get next char using gnc, and if it's not an "@",
C just pass it on. An "@" will trigger a macrograph
C definition or expansion, according to ReGIS rules
C (this is the only level that knows from at-signs)
C If a Sync (;) or Eof is encountered, gxc returns
C Sync and sets syncfl; subsequent calls to gxc/gnbc
C will return Sync until kclrsy is called (this is
C done only at main command level)
C gnbc: get next non-blank using gxc; if it's an upper-
C case letter, convert it to lowercase
C cfind - skip to specified character or Sync
subroutine cfind ( ch )
integer ch
C character to find
integer ch1
continue
23000 continue
call gxc ( ch1 )
23001 if(.not.( ch1 .eq. ch .or. ch1 .eq. 59 ))goto 23000
23002 continue
C get character
end
C chinit - initialize character-handling databases
subroutine chinit
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
gcgel = . false .
C not copying ReGIS input to gelly
peekc = ( - 1 )
C no current "put back" character
qbuf ( 15 ) = 0
C tie off qbuf (never gets changed)
syncfl = 0
C not stuck at Sync
end
C eat1 - return 1 text character, stopping on specified delimiter; if 2
C consecutive delimiters seen, return 1 of them and keep eating
C returns: Next character from string, or Eos (0) if end of string
integer function eat1 ( delim , ch )
integer delim
C delimiter
integer ch
C func value returned here too
integer ch1
continue
23003 continue
call gnc ( ch1 )
23004 if(.not.( ch1 .ne. 0 ))goto 23003
23005 continue
C get next non-null
if(.not.( ch1 .eq. ( - 1 ) ))goto 23006
ch1 = 0
23006 continue
C if eof, signal end-of-string
if(.not.( ch1 .eq. delim ))goto 23008
C is it a delimiter?
call gnc ( ch1 )
C yes, peek at next character
if(.not.( ch1 .ne. delim ))goto 23010
C 2 consecutive delimiters?
call putbak ( ch1 )
C no, replace this character
ch1 = 0
C signal end-of-string
23010 continue
23008 continue
ch = ch1
eat1 = ch1
C return stuff to caller
end
C eattxt - eat text until delimiter seen; if 2 consecutive delimiters
C appear, keep eating. As many characters as possible are
C copied from the string into qbuf (defined in crget).
C The string in qbuf is Eos-terminated, without the delimiters.
C returns: length of string (not including opening and closing delims)
integer function eattxt ( delim )
integer delim
C delimiter
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 ch , n
n = 0
C initialize char count
continue
23012 continue
continue
23015 continue
call gnc ( ch )
C get next character
if(.not.( ch .eq. ( - 1 ) ))goto 23018
return
23018 continue
C return on eof
if(.not.( ch .eq. delim ))goto 23020
goto 23017
C exit loop if it's a delimiter
23020 continue
n = n + 1
C count it
if(.not.( n .lt. 15 ))goto 23022
qbuf ( n ) = ch
23022 continue
C copy char to qbuf
23016 goto 23015
23017 continue
call gnc ( ch )
C 2 consecutive delimiters?
if(.not.( ch .ne. delim ))goto 23024
goto 23014
C no, almost done
23024 continue
n = n + 1
C 2 consec delims, count as 1
if(.not.( n .lt. 15 ))goto 23026
qbuf ( n ) = ch
23026 continue
C copy char to qbuf
23013 goto 23012
23014 continue
call putbak ( ch )
C put back char after delimiter
eattxt = n
C return count to caller
if(.not.( n .lt. 15 ))goto 23028
qbuf ( n + 1 ) = 0
23028 continue
C tie off qbuf
end
C gnbc - get next non-blank character, convert upper case to lower case
subroutine gnbc ( ch )
integer ch
C character returned here
integer ch1
continue
23030 continue
call gxc ( ch1 )
23031 if(.not.( ch1 .gt. 32 .or. ch1 .eq. ( - 1 ) ))goto 23030
23032 continue
if(.not.( ch1 .ge. 65 .and. ch1 .le. 90 ))goto 23033
ch1 = ch1 - 65 + 97
23033 continue
C u/c -> l/c
ch = ch1
C give to caller
end
C gnc - get put-back character, macro character, or file character
subroutine gnc ( ch )
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 ch
C character returned to caller
integer ch1 , getc , mggetc
if(.not.( peekc .ne. ( - 1 ) ))goto 23035
C put-back character present?
ch1 = peekc
C yes, return it
peekc = ( - 1 )
C not present any more
goto 23036
23035 continue
C if expanding a macrograph, get the next character from there
C otherwise, get the next character from the file
if(.not.( mggetc ( ch1 ) .eq. 0 ))goto 23037
C expanding macro?
continue
23039 continue
C no, get char from file
if(.not.( getc ( ch1 ) .lt. 0 ))goto 23042
C eof?
ch = ( - 1 )
C yes, flag it
return
23042 continue
23040 if(.not.( ch1 .ne. 0 ))goto 23039
23041 continue
23037 continue
23036 continue
if(.not.( gcgel ))goto 23044
call gel1 ( ch1 )
23044 continue
C auto-copy to gelly if requested
ch = ch1
C return it to caller
end
C gxc - get next character, checking for macro definition/invocation
subroutine gxc ( ch )
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 ch
C character returned here
integer ch1
if(.not.( syncfl .ne. 0 ))goto 23046
C stuck at Sync?
ch = 59
C yes, cough up a Sync
if(.not.( gcgel ))goto 23048
call gel1 ( 59 )
23048 continue
C auto-copy to gelly if requested
return
C not at Sync, check for macrograph invocation or definition
23046 continue
continue
23050 continue
call gnc ( ch1 )
C get next character
if(.not.( ch1 .eq. 64 ))goto 23053
call mgi
C detour to process macrograph
goto 23054
23053 continue
goto 23052
C not @, proceed
23054 continue
C inhibit reading past Sync/Eof until clrsyn is called
23051 goto 23050
23052 continue
if(.not.( ch1 .eq. 59 .or. ch1 .eq. ( - 1 ) ))goto 23055
syncfl = ch1
ch1 = 59
C convert Eof to Sync
23055 continue
ch = ch1
C give it to caller
end
C kgi - parse an intensity specification of one of the forms
C In where n is one of 0 1 2 3 4 5 6 7
C I(c) where c is one of D B R M G C Y W
C returns: 0 could not parse anything, val set to Null (8)
C 1 parsed a level/color, 0 <= val <= 7
C 2 reserved for HLS (not currently implemented)
integer function kgi ( val )
integer val
integer ch , colors ( 8 ) , i
data colors ( 1 ) , colors ( 2 ) , colors ( 3 ) , colors ( 4 ) / 1
*00 , 98 , 114 , 109 /
data colors ( 5 ) , colors ( 6 ) , colors ( 7 ) , colors ( 8 ) / 1
*03 , 99 , 121 , 119 /
kgi = 0
val = 8
C assume no-parse
call gnbc ( ch )
C get character after I
if(.not.( ch .ge. 48 .and. ch .le. 57 ))goto 23057
C numeric?
call putbak ( ch )
C yes, put digit back for kgnum
call kgnum ( i )
C get number
val = mod ( i , 8 )
C return number modulo 8
kgi = 1
C found level
return
23057 continue
if(.not.( ch .eq. 40 ))goto 23059
C left paren?
continue
23061 continue
call gnbc ( ch )
C yes, get following character
continue
i = 8
23064 if(.not.(i.gt.0))goto 23066
C check for DBRMGCYW
if(.not.( ch .eq. colors ( i ) ))goto 23067
val = i - 1
C got it
kgi = 1
C found something
goto 23066
23067 continue
23065 i=i-1
goto 23064
23066 continue
23062 if(.not.( ch .eq. 41 .or. ch .eq. 59 ))goto 23061
23063 continue
return
C hit I(...) or I(...;
23059 continue
call putbak ( ch )
C not In or I(
end
C kgnum - parse an optionally-signed number in the input stream
integer function kgnum ( num )
C returns 0: fail, 1: unsigned, 2: signed
integer num
C if kgnum > 0, number returned here
integer sign , ch , ndig , val
kgnum = 1
C assume unsigned
sign = 1
C assume positive
ndig = 0
val = 0
C init # of digits, value
call gnbc ( ch )
C get 1st character
if(.not.( ch .eq. 43 .or. ch .eq. 45 ))goto 23069
C sign present?
kgnum = 2
C yes, remember that
if(.not.( ch .eq. 45 ))goto 23071
sign = - 1
23071 continue
C remember the sign
call gnbc ( ch )
C get character after sign
23069 continue
continue
23073 if(.not.( ch .ge. 48 .and. ch .le. 57 ))goto 23074
ndig = ndig + 1
C count # of digits
val = val * 10 + ch - 48
C shift and add
call gnbc ( ch )
C get next character
goto 23073
23074 continue
call putbak ( ch )
C put back non-digit
if(.not.( ndig .gt. 0 ))goto 23075
num = val * sign
C if legal number, return it
goto 23076
23075 continue
kgnum = 0
23076 continue
C otherwise, return error
end
C ksync - return Sync/Eof if stuck at Sync/Eof, else return 0
C If argument is non-zero, clear syncfl (this is done
C only by the main ReGIS command dispatcher)
integer function ksync ( f )
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 f
C non-zero to clear syncfl
ksync = syncfl
if(.not.( f .ne. 0 ))goto 23077
syncfl = 0
23077 continue
end
C kterm - return 1 if arg is a "terminator", where "terminator" is
C defined as a-z, ), or Sync; best fed with characters
C gotten from gnbc (the definiton of "terminator" is derived
C from the "gscant" routine in the VK100 microcode)
integer function kterm ( ch )
integer ch
C argument character
kterm = 0
if(.not.( ( ch .ge. 97 .and. ch .le. 122 ) .or. ch .eq. 41 .or. ch
* .eq. 59 ))goto 23079
kterm = 1
23079 continue
end
C letter - check if the argument is a letter
C returns: 1 if argument was a letter, else 0
integer function letter ( ch )
integer ch
C character to test, not modified by subr
letter = 0
if(.not.( ( ch .ge. 65 .and. ch .le. 90 ) .or. ( ch .ge. 97 .and.
*ch .le. 122 ) ))goto 23081
letter = 1
23081 continue
end
C lower - check for a letter, converting upper case to lower case
C returns: 1 if argument was a letter, else 0
integer function lower ( ch )
integer ch
C uppercase letter changed to lowercase
if(.not.( ch .ge. 65 .and. ch .le. 90 ))goto 23083
ch = ch - 65 + 97
23083 continue
C uc -> lc
lower = 0
if(.not.( ch .ge. 97 .and. ch .le. 122 ))goto 23085
lower = 1
23085 continue
end
C putbak - put back a character that was read with gnc, gxc, gnbc
subroutine putbak ( ch )
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 ch
C character to put back
if(.not.( gcgel ))goto 23087
call geld1
23087 continue
C if auto-copy, delete last gel
if(.not.( syncfl .ne. 0 ))goto 23089
return
C don't put back Sync's; they
C will be handled by gxc
23089 continue
if(.not.( peekc .ne. ( - 1 ) ))goto 23091
call imerr ( 23 )
23091 continue
C BUG if peekc != Eof
peekc = ch
C remember character
end
C quotch - scan quoted string and return first character
C returns: first character of string, or 0 if null string
integer function quotch ( delim )
integer delim
C delimiter (Quote1 or Quote2)
integer ch , eattxt
call gnc ( ch )
call putbak ( ch )
C peek at next character
if(.not.( eattxt ( delim ) .eq. 0 ))goto 23093
ch = 0
23093 continue
C scan to closing delim
quotch = ch
C give value to caller
end
C skpbal - skip balanced constructs (lifted from VK100 microcode)
C ( ... )
C [ ... ]
C " ... "
C ' ... '
C returns: 1 if quoted string parsed, else 0
integer function skpbal ( ich )
integer ich
C if 0, skpbal has to get the first character
C otherwise, ich is the first character
integer ch , nest
ch = ich
C was character supplied?
if(.not.( ich .eq. 0 ))goto 23095
call gnbc ( ch )
23095 continue
C no, have to get it
skpbal = 0
C assume not a string
if(.not.( ch .eq. 40 ))goto 23097
C ( ?
nest = 1
C yes, init () level
continue
23099 continue
call gnbc ( ch )
C get character
if(.not.( ch .eq. 40 ))goto 23102
nest = nest + 1
23102 continue
if(.not.( ch .eq. 41 ))goto 23104
nest = nest - 1
23104 continue
if(.not.( ch .eq. 39 .or. ch .eq. 34 ))goto 23106
call eattxt ( ch )
23106 continue
23100 if(.not.( nest .le. 0 .or. ch .eq. 59 ))goto 23099
23101 continue
return
23097 continue
if(.not.( ch .eq. 91 ))goto 23108
C [ ?
continue
23110 continue
C yes
call gnbc ( ch )
C get character
if(.not.( ch .eq. 39 .or. ch .eq. 34 ))goto 23113
call eattxt ( ch )
23113 continue
23111 if(.not.( ch .eq. 93 .or. ch .eq. 59 ))goto 23110
23112 continue
return
23108 continue
if(.not.( ch .eq. 39 .or. ch .eq. 34 ))goto 23115
C quoted string?
call eattxt ( ch )
C yes, munch it
skpbal = 1
C say string parsed
return
23115 continue
if(.not.( ich .eq. 0 ))goto 23117
call putbak ( ch )
23117 continue
C not skippable
end