Trailing-Edge
-
PDP-10 Archives
-
BB-K818A-BM_1981
-
sources/imacro.for
There are no other files named imacro.for in the archive.
C imacro> Macrograph definition, expansion, and storage management
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 Macrograph (mg) storage:
C
C Mg's are stored as linked lists of MGPSZ-character pages.
C Each page has a number; page numbers are between 1 and MGPGS.
C
C Data bases:
C
C mgplnk(page#) contains the page number of the next page in the
C chain, or 0 if there is no next page.
C
C mgptxt(page#,*) is the page itself; it contains the characters
C that live in the page; if the mg doesn't end in this page, all
C MGPSZ characters of the page are used; if the mg ends in this
C page and doesn't occupy the entire page, it is followed by a null
C
C mgfree contains the page number of the first page on the
C free list, or 0 if the free list is empty
C
C mgtab(index) contains the first page number of a mg definition,
C or 0 if the mg is not defined; index equals the lower-case mg
C name minus "a" plus 1 (e.g., mg "a" has index 1, "b" 2, etc.)
C
C mglvl contains the current nesting level of mg expansion, or
C 0 if no mg is currently being expanded
C
C mxtab(lvl,what) contains pointers to macrograph(s) currently
C being expanded; lvl is the nesting level (mglvl); what = 1
C gets you the page #, what = 2 gets you the character number
C within the page
C These "defines" control attributes of macrograph storage
C number of pages for macrograph storage
C size (characters) of a macrograph page
C maximum nesting level for macrographs
C mgclr - initialize macrograph storage, called at startup
subroutine mgclr
C cmg> Macrograph COMMON
integer mgfree
C page # of head of free macrograph page list
integer mglvl
C nesting level for macrograph expansion
C 0 means no mg currently being expanded
integer mgplnk ( 150 )
C page # of next page in chain, or 0 if none
integer mgptxt ( 150 , 16 )
C "pages" used to store macrographs
integer mgtab ( 26 )
C subscript: <mgname> - Leta + 1
C contents: page # of 1st page of mg definition
C or 0 if the mg is not defined
integer mxtab ( 26 , 2 )
C stack of info about macros being expanded
C 1st subscript: nesting level
C 2nd subscript: 1 = page number,
C 2 = character # within the page
common / cmg / mgfree , mglvl , mgplnk , mgptxt , mgtab , mxtab
integer i
mglvl = 0
C not expanding any mg's
C initialize storage by linking all pages on free list
continue
i = 1
23000 if(.not.(i.lt.150))goto 23002
mgplnk ( i ) = i + 1
23001 i=i+1
goto 23000
23002 continue
mgplnk ( 150 ) = 0
C set tail to null
mgfree = 1
C set head of free list
C set macrographs a-z to null
continue
i = 26
23003 if(.not.(i.gt.0))goto 23005
mgtab ( i ) = 0
23004 i=i-1
goto 23003
23005 continue
end
C mgdef - add a macrograph definition to the mg tables
C called after "@:" has been scanned
subroutine mgdef
integer ch , lower , mtx
integer p1
C current page number
integer p2
C index into page
C cmg> Macrograph COMMON
integer mgfree
C page # of head of free macrograph page list
integer mglvl
C nesting level for macrograph expansion
C 0 means no mg currently being expanded
integer mgplnk ( 150 )
C page # of next page in chain, or 0 if none
integer mgptxt ( 150 , 16 )
C "pages" used to store macrographs
integer mgtab ( 26 )
C subscript: <mgname> - Leta + 1
C contents: page # of 1st page of mg definition
C or 0 if the mg is not defined
integer mxtab ( 26 , 2 )
C stack of info about macros being expanded
C 1st subscript: nesting level
C 2nd subscript: 1 = page number,
C 2 = character # within the page
common / cmg / mgfree , mglvl , mgplnk , mgptxt , mgtab , mxtab
C get name of macrograph and make sure it's a letter
call gnc ( ch )
C get mg name
if(.not.( lower ( ch ) .eq. 0 ))goto 23006
C is it a letter?
call imerr ( 7 )
C bad mg name
call mgskip
C skip to @;
return
C name OK, now add mg to memory
23006 continue
mtx = ch - 97 + 1
C make mgtab subscript
call mgdel ( ch )
C delete current def
p1 = 0
C no pages assigned yet
continue
23008 continue
call gnc ( ch )
C get next char
if(.not.( ch .eq. 0 ))goto 23011
goto 23009
C skip nulls
23011 continue
if(.not.( ch .eq. ( - 1 ) ))goto 23013
goto 23010
C Eof means end-of-mg
23013 continue
if(.not.( ch .eq. 64 ))goto 23015
C @... check for @;
call gnc ( ch )
C get char after @
if(.not.( ch .eq. 59 ))goto 23017
goto 23010
C @;
23017 continue
call mgputc ( 64 , p1 , p2 )
C something else
23015 continue
call mgputc ( ch , p1 , p2 )
C put character in page
C if first character, store pointer to 1st page in mgtab
if(.not.( mgtab ( mtx ) .eq. 0 ))goto 23019
mgtab ( mtx ) = p1
23019 continue
C end of macrograph definition, wrap it up
23009 goto 23008
23010 continue
call mgputc ( 0 , p1 , p2 )
end
C mgdel - delete the definition of a macrograph, freeing its pages
subroutine mgdel ( ch )
integer ch
C name (a-z) of mg to delete
C cmg> Macrograph COMMON
integer mgfree
C page # of head of free macrograph page list
integer mglvl
C nesting level for macrograph expansion
C 0 means no mg currently being expanded
integer mgplnk ( 150 )
C page # of next page in chain, or 0 if none
integer mgptxt ( 150 , 16 )
C "pages" used to store macrographs
integer mgtab ( 26 )
C subscript: <mgname> - Leta + 1
C contents: page # of 1st page of mg definition
C or 0 if the mg is not defined
integer mxtab ( 26 , 2 )
C stack of info about macros being expanded
C 1st subscript: nesting level
C 2nd subscript: 1 = page number,
C 2 = character # within the page
common / cmg / mgfree , mglvl , mgplnk , mgptxt , mgtab , mxtab
integer mp , mp1
mp = mgtab ( ch - 97 + 1 )
C is this mg defined?
if(.not.( mp .eq. 0 ))goto 23021
return
23021 continue
C no, nothing to do
mgtab ( ch - 97 + 1 ) = 0
C mark mg undefined
C the rest of the subroutine frees up the pages assigned to this mg
mp1 = mp
continue
23023 continue
if(.not.( mgplnk ( mp1 ) .eq. 0 ))goto 23026
goto 23025
C stop at end of def
23026 continue
mp1 = mgplnk ( mp1 )
C step to next page
C mp1 now has the page # of the last page of the mg's definition
C set new-free-list = definition + old-free-list
23024 goto 23023
23025 continue
mgplnk ( mp1 ) = mgfree
C new tail -> old head
mgfree = mp
C set new free list head
end
C mggetc - get next character from currently-active macrograph
C returns: 0 if no macrograph active
C else current macrograph level
integer function mggetc ( ch )
integer ch
C character returned here iff func value > 0
C cmg> Macrograph COMMON
integer mgfree
C page # of head of free macrograph page list
integer mglvl
C nesting level for macrograph expansion
C 0 means no mg currently being expanded
integer mgplnk ( 150 )
C page # of next page in chain, or 0 if none
integer mgptxt ( 150 , 16 )
C "pages" used to store macrographs
integer mgtab ( 26 )
C subscript: <mgname> - Leta + 1
C contents: page # of 1st page of mg definition
C or 0 if the mg is not defined
integer mxtab ( 26 , 2 )
C stack of info about macros being expanded
C 1st subscript: nesting level
C 2nd subscript: 1 = page number,
C 2 = character # within the page
common / cmg / mgfree , mglvl , mgplnk , mgptxt , mgtab , mxtab
integer p1 , p2
100 mggetc = 0
C assume not in mg
if(.not.( mglvl .eq. 0 ))goto 23028
return
23028 continue
C return if that's so
p1 = mxtab ( mglvl , 1 )
C get current page#
p2 = mxtab ( mglvl , 2 ) + 1
C get char # in page
if(.not.( p2 .gt. 16 ))goto 23030
C end of page?
p1 = mgplnk ( p1 )
C yes, get # of next page
if(.not.( p1 .eq. 0 ))goto 23032
C any more pages?
mglvl = mglvl - 1
C no, end of this mg
goto 100
C try at next lower level
23032 continue
mxtab ( mglvl , 1 ) = p1
C remember current page#
p2 = 1
C reset char# in page
23030 continue
mxtab ( mglvl , 2 ) = p2
C set new char# in page
ch = mgptxt ( p1 , p2 )
C get character from page
if(.not.( ch .eq. 0 ))goto 23034
C end of macrograph?
mglvl = mglvl - 1
C yes, drop down 1 level
goto 100
C try it there
23034 continue
mggetc = mglvl
C give level to caller
end
C mgi - process the character following an "@"
C this is either a macrograph definition or invocation
subroutine mgi
integer ch , lower
C cmg> Macrograph COMMON
integer mgfree
C page # of head of free macrograph page list
integer mglvl
C nesting level for macrograph expansion
C 0 means no mg currently being expanded
integer mgplnk ( 150 )
C page # of next page in chain, or 0 if none
integer mgptxt ( 150 , 16 )
C "pages" used to store macrographs
integer mgtab ( 26 )
C subscript: <mgname> - Leta + 1
C contents: page # of 1st page of mg definition
C or 0 if the mg is not defined
integer mxtab ( 26 , 2 )
C stack of info about macros being expanded
C 1st subscript: nesting level
C 2nd subscript: 1 = page number,
C 2 = character # within the page
common / cmg / mgfree , mglvl , mgplnk , mgptxt , mgtab , mxtab
call gnc ( ch )
C get character after "@"
if(.not.( lower ( ch ) .ne. 0 ))goto 23036
call mglkup ( ch )
C letter, do expansion
goto 23037
23036 continue
if(.not.( ch .eq. 46 ))goto 23038
C dot, clear all macros
if(.not.( mglvl .eq. 0 ))goto 23040
C expanding?
continue
ch = 97
23042 if(.not.(ch.le.122))goto 23044
call mgdel ( ch )
23043 ch=ch+1
goto 23042
23044 continue
C no
goto 23041
23040 continue
call imerr ( 5 )
23041 continue
C yes, signal error
goto 23039
23038 continue
if(.not.( ch .eq. 58 ))goto 23045
C colon, mg definition
C macrographs may be defined only if the processor
C is not currently expanding a macrograph
if(.not.( mglvl .eq. 0 ))goto 23047
call mgdef
C if at level 0, define
goto 23048
23047 continue
C expanding. well...
call imerr ( 5 )
C signal error
call mgskip
C ignore the definition
23048 continue
goto 23046
23045 continue
if(.not.( ch .eq. ( - 1 ) ))goto 23049
return
C @Eof ... Why me??
goto 23050
23049 continue
call imerr ( 6 )
23050 continue
23046 continue
23039 continue
23037 continue
C unknown char after "@"
end
C mglkup - process macrograph invocation
subroutine mglkup ( ch )
integer ch
C macro name (a-z)
integer mtx
C cmg> Macrograph COMMON
integer mgfree
C page # of head of free macrograph page list
integer mglvl
C nesting level for macrograph expansion
C 0 means no mg currently being expanded
integer mgplnk ( 150 )
C page # of next page in chain, or 0 if none
integer mgptxt ( 150 , 16 )
C "pages" used to store macrographs
integer mgtab ( 26 )
C subscript: <mgname> - Leta + 1
C contents: page # of 1st page of mg definition
C or 0 if the mg is not defined
integer mxtab ( 26 , 2 )
C stack of info about macros being expanded
C 1st subscript: nesting level
C 2nd subscript: 1 = page number,
C 2 = character # within the page
common / cmg / mgfree , mglvl , mgplnk , mgptxt , mgtab , mxtab
mtx = ch - 97 + 1
C get mgtab subscript
if(.not.( mgtab ( mtx ) .eq. 0 ))goto 23051
return
23051 continue
C return if not defined
if(.not.( mglvl .ge. 26 ))goto 23053
C nested too deeply?
call imerr ( 9 )
C yes, probably recursive
return
23053 continue
mglvl = mglvl + 1
C nest 1 more level
mxtab ( mglvl , 1 ) = mgtab ( mtx )
C set page # for fetching
mxtab ( mglvl , 2 ) = 0
C set character # in page
end
C mgputc - add a character to a macrograph definition
subroutine mgputc ( ch , p1 , p2 )
integer ch
C character to be added; if Eos, add it only if there exists
C a current page and the page isn't full
integer p1
C page number of page where character is being added; if zero,
C this is the first char of this macro; mgputc updates p1 when
C it needs a new page because the last one filled up
integer p2
C index to last character stored in the page; incremented by 1,
C and reset when a new page is assigned
C cmg> Macrograph COMMON
integer mgfree
C page # of head of free macrograph page list
integer mglvl
C nesting level for macrograph expansion
C 0 means no mg currently being expanded
integer mgplnk ( 150 )
C page # of next page in chain, or 0 if none
integer mgptxt ( 150 , 16 )
C "pages" used to store macrographs
integer mgtab ( 26 )
C subscript: <mgname> - Leta + 1
C contents: page # of 1st page of mg definition
C or 0 if the mg is not defined
integer mxtab ( 26 , 2 )
C stack of info about macros being expanded
C 1st subscript: nesting level
C 2nd subscript: 1 = page number,
C 2 = character # within the page
common / cmg / mgfree , mglvl , mgplnk , mgptxt , mgtab , mxtab
logical mspace
C set .false. once "out of space" error has been given
data mspace / . true . /
if(.not.( ch .eq. 0 .and. ( p1 .eq. 0 .or. p2 .ge. 16 ) ))goto 230
*55
return
23055 continue
C no new page for Eos
if(.not.( p1 .eq. 0 ))goto 23057
p2 = 16
23057 continue
C get page on 1st char
p2 = p2 + 1
C point to next char
if(.not.( p2 .gt. 16 ))goto 23059
C out of room?
if(.not.( mgfree .eq. 0 ))goto 23061
C yes, any free pages?
if(.not.( mspace ))goto 23063
call imerr ( 8 )
23063 continue
C no, signal error
mspace = . false .
C only once per run
return
C no action
23061 continue
p2 = 1
C back to start of page
if(.not.( p1 .ne. 0 ))goto 23065
mgplnk ( p1 ) = mgfree
23065 continue
C old tail -> new tail
p1 = mgfree
C current page = new tail
mgfree = mgplnk ( mgfree )
C remove from free list
mgplnk ( p1 ) = 0
C point new tail to null
23059 continue
mgptxt ( p1 , p2 ) = ch
C store char in page
end
C mgskip - skip over a macrograph definition by searching for "@;"
subroutine mgskip
integer ch
continue
23067 continue
call gnc ( ch )
C get character
if(.not.( ch .eq. ( - 1 ) ))goto 23070
return
23070 continue
if(.not.( ch .eq. 64 ))goto 23072
C @ ?
call gnc ( ch )
C yes, get following char
if(.not.( ch .eq. 59 .or. ch .eq. ( - 1 ) ))goto 23074
return
23074 continue
C return on @;
23072 continue
23068 goto 23067
23069 continue
end