Google
 

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