       program xchek

c      version iiic  June 2008 -- adhering to ddl 3.7.11
c
c      contact author Syd Hall (sydney.hall@uwa.edu.au)
c
c xchek checks the tags in any text file against a designated dictionary
c file.  the dictionary file (in ddl1, 2, or 3 format) is opened as 'XDICT'.
c the input text file is expanded if it is recognised as a dictionary and
c all imported definitions are added - the expanded file is stored in the
c file 'XTEXT' and the location of all tags appearing in the generated
c report 'XCHEK' refer to the line numbers in 'XTEXT'.
c Messages are output to the standard output device (normally device 6).
c
c Note that the variable 'maxc' is the maximum number of characters in
c a single input and output line - the preset value is 125.
c
c
c .............................installation notes.............................
c
c  data common definitions appear in the file 'xchek.cmn'.
c
c  names ignored  input from 'XNAME' on device 3 (opened in routine loaddl)
c  report on names output on 'XCHEK' on device 4 (opened in routine report)
c  text file to be checked   'INTEX' on devices 11-35 (read in routine readtx)
c  expanded text checked as  'XTEXT' on device 11 (generated in routine readtx)
c  error messages outout on          on device 6 ('stdout')
c  'XDICT' & imported dictionaries   on devices 11-35.
c
c ..........................................................................
c
      include 'xchek.cmn'
c
c                  ------- if h .true. print import History   
      h=.true.
c                  ------- if d .true. print diagnostic Dumps
      d=.false.
c                  ------- if r .true. print Readln input buffer    
      r=.false.
c                  ------- if s .true. print getstr String returns
      s=.false.
c            v----------------------max chars input text file
      maxc=125 
      maxnam=5000
      case=ichar('a')-ichar('A')
      tab=char(05)
      if(case.ge.0) tab=char(09)
c
c
      write(*,'(/10(1h>),a,10(1h<)/)')' XCHEK - dataname cross-check '
c
c                    step 1: read XDICT & build table of defined tags
      call loaddl
c                    step 2: read INTEX expand to XTEMP & XTEXT    
      call readtx
c                    step 3: read XTEXT for all tags; exclude in XNAME
      call chekdn
c                    step 4: report tags found in XTEXT wrt XDICT
      call report
c
100   continue
      end
c
c***************************************************************************
c     loaddl stores tags from the dictionary file XDICT. gettag extracts
c     tags from parent and all imported definitions and returns name()
c***************************************************************************
c
      subroutine loaddl
      include 'xchek.cmn'
      integer i,j
      character nona*21
      data nona/',([{</|".?!;:)]}>/-=|'/
c
c-------------------------------------- reset the dictionary tag list
      noop=1
      audf=1
      dicf=1
      nhis=-1
      ncnt=0
      mdef=0
      nbuf=0
      xcnt=0
      iatt=0
      loop=0
      texf=0
      indx=0
      savf=0
      impf=0
      nfil=0
      mfil=0
      stri=' '
      ddlv=' '
      name=' '
      do 5 i=1,25
      ndic(i)=0
      mdic(i)=0
      devn(i)=i+10
      do 5 j=1,25
      do 5 k=1,4
5     dict(i,j,k)=' '
      do 10 i=1,maxnam
      lnam(i)=0
10    dnam(i)=' '
c-------------------------------------- open parent dictionary XDICT
      scop=' '
      deft=' '
      filn='XDICT'
      dupl=' '
      miss=' '
      call newfil
c-------------------------------------- get defined tags & check dups
20    call gettag
cdbug write(6,'(3i5,5x,a,5x,2a30)') ieof,ncnt,nchr,ddlv,stri,name
      if(ieof.ne.0)    goto 100
      call adddic
      goto 20
c
100   continue
      dicf=0
cdbug write(6,'(//a)') '>>>>> dictionary tags stored are:'
cdbug write(6,'(2i3,5x,2a40)') (i,lnam(i),inam(i),dnam(i),i=1,ncnt)
cdbug write(6,'(///)')
      return
      end
c
c***************************************************************************
c     readtx reads input text file 'INTEX' and generates the file 'XTEMP'
c     which contains any imported data if the INTEX text file is also a
c     dictionary. Then reads XTEMP and writes XTEXT checking for duplicate
c     definitions.
c     "dict" signals that INTEX is a dictionary and imports executed.
c***************************************************************************
c
      subroutine readtx
      include 'xchek.cmn'
      integer i,j,n,dicy
      character t*60,f*1,f1*1,f2*1
c
      noop=1
      nstr=0
      loop=0
      ntag=0
      ntex=0
      dicy=0
      dicf=0
      mfil=0
      nhis=0
      texf=1
      indx=0
      savf=0
      impf=0
      do 2 i=1,5000
      tag1(i)=0
      tag2(i)=0
      tagl(i)=0
      tagh(i)=0
2     tagn(i)=' '
      do 5 i=1,25
      ndic(i)=0
      mdic(i)=0
      devn(i)=i+10
      do 5 j=1,25
      do 5 k=1,4
5     dict(i,j,k)=' '
      do 8 i=1,100
      do 8 j=1,25
      do 8 k=1,5
8     hist(i,j,k)=' '
c
c ======== read input text (INTEX) write (expanded) XTEMP ========
c
      scop=' '
      deft=' '
      filn='INTEX'
      dupl=' '
      miss=' '
      nfil=0
      call newfil
      open(7,file='XTEMP',status='new',form='formatted')
C
10    call getstr
      if(ieof.ne.0)  goto 100
cdbug write(6,'(4i5,x,a,x,a)') ndev,nfil,dicy,nchr,type,stri(1:nchr)
      if(dicy.eq.0.and.type.eq.'name')  goto 30
      if(type.ne.'name')                goto 10
      if(stri(2:7).eq.'import')         call import
      if(type.ne.'name')                goto 10
30    if(nstr.gt.20)  goto 10
      nstr=nstr+1
      if(stri(1:17).ne.'_dictionary.title') goto 10
      dicy=1
      goto 10
c
100   close(7)
      if(.not.h) goto 110
	  write(6,'(/a)') ' IMPORT HISTORY......'
      do 105 i=1,nhis
      write(6,'(/a,i3,a,11x,a,15x,a,4x,a)') ' POP',i,
     * ' NFIL SCOPE BLOCKNAME','FILE','IF_DUPL','IF_MISS'
      j=1
103   write(6,'(i11,3x,a5,a20,a20,a10,a10)') j,(hist(i,j,k),k=1,5)
      j=j+1
      if(hist(i,j,3)(1:1).ne.' ') goto 103
105   continue
c
c ======== read (expanded) XTEMP and write XTEXT =======================
c
110   open(7,file='XTEMP',status='old',form='formatted')
      open(8,file='XTEXT',status='new',form='formatted')
c -------------------------------------- is XTEMP an expanded dictionary?
      if(dicy.eq.1) goto 200
c------------------------------------------ not a dic; direct copy to XTEXT
120   read(7,'(a)',end=400) ibuf(1:maxc)
      write(8,'(a)')        ibuf(1:maxc)
      goto 120
c------------------------------------------ is a dic; copy unique defs only
200   nfil=mfil
210   nfil=nfil-1
      if(nfil.eq.0) goto 300
      do 290 i=1,ntag
cdbug write(6,'(5i5,x,a)') i,tagl(i),tagh(i),tag1(i),tag2(i),tagn(i)
      if(tagl(i).lt.nfil) goto 290
      if(tagh(i).lt.0)    goto 290
      t=tagn(i)
      k=0
cdbug write(6,'(3i5,5x,a30)')i,tagl(i),tagh(i),tagn(i)
      do 220 j=i+1,ntag
      if(tagl(j).lt.nfil) goto 220
      if(tagh(j).lt.0)    goto 220
      if(tagn(j).ne.t)    goto 220
      if(k.gt.0) call err(2,'multiple imported tags for',t)
      k=j
220   continue
      if(k.eq.0) goto 290
c                                   duplicate detected; apply protocol
      f1=' '
      f2=' '
      if(tagl(i).gt.nfil) f1=hist(tagh(i),nfil+1,4)(1:1)
      if(tagl(k).gt.nfil) f2=hist(tagh(k),nfil+1,4)(1:1)
cdbug write(6,'(4i5,x,2a2,x,a30)')i,k,tagh(i),tagh(k),f1,f2,tagn(i)
      if(f1.eq.f2) call err(2,'duplicate parent or import tags',t)
      if(f1.eq.'e'.or.f2.eq.'e')call err(2,'tag duplicate "exit"',t)
      if(f1.ne.' ') goto 250
      if(f2.eq.'r') goto 270
      if(f2.eq.'i') goto 260
250   if(f2.ne.' ') call err(2,'different import duplicate codes',t)
      if(f1.eq.'r') goto 260
      if(f1.eq.'i') goto 270
      call err(2,'unrecognised import duplicate codes',t)
c
260   tagh(k)=-tagh(k)
      goto 290
270   tagh(i)=-tagh(i)
290   continue
      goto 210
c------------------------------ scan tag table; reject if -ve tagh()
300   continue
cdbug write(6,'(2i5,x,a60)')(i,tagh(i),tagn(i),i=1,ntag)
      do 310 i=1,tag1(1)-1
      read(7,'(a)' ) ibuf(1:maxc)
310   write(8,'(a)') ibuf(1:maxc)
c
      do 350 i=1,ntag
      n=tagh(i)
      if(i.eq.1) goto 325
      do 320 j=tag2(i-1)+1,tag1(i)-1
320   read(7,'(a)')  ibuf(1:maxc)
325   do 330 j=tag1(i),tag2(i)
      read(7,'(a)',end=400)  ibuf(1:maxc)
330   if(n.gt.0)  write(8,'(a)') ibuf(1:maxc)
350   continue
c
      do 360 i=tag2(ntag)+1,ntex
      read(7,'(a)',end=400 ) ibuf(1:maxc)
360   write(8,'(a)') ibuf(1:maxc)
c------------------------------------------- XTEXT is complete
400   close(7)
      close(8)
      return
      end
c
c***************************************************************************
c     chekdn reads the XTEXT file for tags and checks them against the
c     dictionary names in dnam().  if a tag is not present it is added
c     to the end of dnam(). the line numbers are added to npos().
c     getstr supplies strings as 'stri' of length 'nchr'.
c***************************************************************************
 
      subroutine chekdn
      include 'xchek.cmn'
      integer i,j,n
c
      character head*10,tail*16,c*1,nona*21
      data nona/',([{</|".?!;:)]}>/-=|'/
      data head/' ,([{</|" '/
      data tail/' ,.?!;:)}>/-=|" '/
      character*60 xnam(1000)
      integer      xlen(1000),xmax,dicy,nstr
c
c -------------------------------------- enter XNAME (names to be ignored)
      xmax=1000
      open(3,file='XNAME',status='old',form='formatted')
2     xcnt=xcnt+1
      if(xcnt.le.xmax) goto 4
      write(6,'(a)') 'XNAME list > xnam array. reset limits & xmax'
      stop
4     read(3,'(a)', end=8) xnam(xcnt)
      n=0
6     n=n+1
      if(n.gt.60) goto 7
      if(xnam(xcnt)(n:n).ne.' ') goto 6
      if(n.eq.1) goto 4
7     xlen(xcnt)=n-1
Cdbug write(6,'(2i5,5x,a)') xcnt,xlen(xcnt),xnam(xcnt)
      goto 2
8     xcnt=xcnt-1
      close(3)
c -------------------------------------- enter XTEXT to be checked
      mcnt=ncnt+1
      head(1:1)=''''
      head(10:10)=tab
      tail(1:1)=''''
      tail(16:16)=tab
      stri=' '
      nstr=0
      dicy=0
      audf=0
      texf=0
c-------------------------------------- open generated text file XTEXT
      scop=' '
      deft=' '
      filn='XTEXT'
      dupl=' '
      miss=' '
      nfil=0
      call newfil
c-------------------------------------- get text tokens from getstr
10    call getstr
      if(ieof.ne.0)  goto 200
      i=1
      j=nchr
      if(type.ne.'name')   goto 16
      if(dicy.eq.0)   goto 14
	  if(loop.eq.0)   goto 14
      if(stri(1:nchr).eq.'_dictionary_history')          goto 13
      if(stri(1:nchr).eq.'_dictionary_history.revision') goto 13
      if(stri(1:nchr).ne.'_dictionary_audit.revision')   goto 20
13    audf=1
      dicy=0
      goto 20
c
14    if(nstr.gt.20)  goto 20
      nstr=nstr+1
      if(stri(1:11).ne.'_dictionary') goto 20
      if(stri(12:16).eq.'_name')      goto 15
      if(stri(12:16).ne.'.titl')      goto 20
15    dicy=1
      goto 20
c -------------------------------------- look for data name in string
16    if(type.ne.'char')  goto 10
      do 19 i=1,nchr
      if(stri(i:i).eq.'_') goto 20
19    continue
      goto 10
c
20    if(i.eq.1) goto 22
      if(index(head,stri(i-1:i-1)).eq.0) goto 10
22    if(stri(i+1:i+1).eq.'_') goto 10
cdbug write(6,'(20x,3i5,x,a)') line(nfil),audf,loop,stri(1:nchr)
      if(index(nona,stri(i+1:i+1)).gt.0) goto 10
      do 25 j=nchr,i,-1
      if(index(tail,stri(j:j)).eq.0) goto 30
25    continue
30    n=j-i+1
      if(n.lt.2) goto 10
cdbug write(6,'(2i5,5x,a,a)') i,n,name(1:30),stri(i:j)
      if(i.eq.1)                                   goto 34
      if(name(1:20).eq.'_alias.definition_id')     goto 10
      if(name(1:13).eq.'_item_aliases')            goto 10
c
c -------------------------------------- identify mode of search
34    if(nchr.gt.60)call err(0,'data name in text is > 60 chars',
     *        stri(i:j))
      name=' '
      m=0
cdbug write(6,'(2i5,2a)') i,j,ddlv,stri(i:j)
      n=i-1
35    n=n+1
      if(n.gt.j)    goto 39
      if(stri(n:n).eq.' ')  goto 39
      if(ddlv.ne.'3')       goto 37
      if(stri(n:n).eq.'(')  goto 36
      if(stri(n:n).ne.'[')  goto 37
36    n=n+1
      if(n.gt.j)    goto 39
      if(stri(n:n).eq.')')  goto 35
      if(stri(n:n).ne.']')  goto 36
      goto 35
37    c=stri(n:n)
      m=m+1
      if(c.ge.'A'.and.c.le.'Z') goto 38
      name(m:m)=c
      goto 35
38    name(m:m)=char(ichar(c)+case)
      goto 35
c ---------------------------------------- test tag for trailing chars
39    if(name(m:m).eq.'_')     goto 50
      if(name(m:m).eq.'.')     goto 50
      if(name(m:m).eq.'*')     goto 49
40    if(name(m-1:m).ne.'[]')  goto 41
      m=m-2
      if(name(m-1:m).ne.'[]')  goto 50
      m=m-2
      goto 50
41    if(i.eq.1)               goto 42
      if(stri(i-1:i-1).eq.'*') goto 60
c --------------------------------------- search for full data name
42    nnn=1
      do 43 i=1,ncnt
      if(name.eq.dnam(i)) goto 44
43    continue
      nnn=0
c                                          check if name to be ignored
44    do 46 n=1,xcnt
      if(xlen(n).ne.m)    goto 46
      if(xnam(n).eq.name) goto 48
46    continue
      if(nnn.eq.1) goto 170
      goto 100
48    npos(i,1)=-1
      goto 10
c ---------------------------------------- search for group data name
49    m=m-1
50    do 55 i=1,ncnt
      if(name(1:m).eq.dnam(i)(1:m)) goto 170
55    continue
      goto 100
c ---------------------------------------- search for end-part data name
60    do 65 i=1,ncnt
      n=lnam(i)
      if(m.gt.n) goto 65
      if(name(1:m).eq.dnam(i)(n-m+1:n)) goto 170
65    continue
 
c ---------------------------------------- new data name add to list
100   ncnt=ncnt+1
      if(ncnt.le.maxnam) goto 150
      call err(1,'data name table exceeded. current max is','5000')
150   dnam(ncnt)=name
      inam(ncnt)=name
      lnam(ncnt)=m
cdbug write(6,'(3i5,2a30)') ncnt,m,n,name,stri(1:nchr)
      do 160 j=1,100
160   npos(ncnt,j)=0
      i=ncnt
c --------------------------------------- add line numbers to npos()
170   if(npos(i,1).eq.99) goto 10
      if(npos(i,1).eq.-1) goto 10
      npos(i,1)=npos(i,1)+1
      n=npos(i,1)
      if(n.ne.99)    goto 180
      write(6,'(a,a)') 'warning: line table truncated for ',name
180   npos(i,n+1)=line(nfil)
      go to 10
c
200   return
      end
c
c***************************************************************************
c     report prints a summary of the line occurrences for each data name
c     in the dictionary and the text file itself (if it does not appear
c     in the dictionary). this summary is output as the file xchek.
c***************************************************************************
c
      subroutine report
      include 'xchek.cmn'
      integer i,j,n
c
      open(4,file='XCHEK',status='new',form='formatted')
      n=0
      do 10 i=1,mcnt-1
      if(npos(i,1).eq.0) goto 10
      n=n+1
10    continue
c
      write(*,'(35h   data names defined in XDICT file,i5)') mcnt-1
      write(*,'(35h   XTEXT _strings not in XDICT file,i5)') ncnt-mcnt+1
      write(*,'(35h   XTEXT _strings in the XDICT file,i5)') n
      write(*,'(35h   ignored data names in XNAME file,i5)') xcnt
 
      write(4,'(1x,10(1h>),a,10(1h<)/)')' XCHEK - dataname cross-check '
      write(4,'(35h   data names defined in XDICT file,i5)') mcnt-1
      write(4,'(35h   XTEXT _strings not in XDICT file,i5)') ncnt-mcnt+1
      write(4,'(35h   XTEXT _strings in the XDICT file,i5)') n
      write(4,'(35h   ignored data names in XNAME file,i5)') xcnt
c
      write(4,'(//a,12(1h-),a/)') ' XTEXT names not in dictionary ',
     * ' line numbers in XTEXT file -----------'
      do 50 i=mcnt,ncnt
      n=npos(i,1)
      if(n.gt.0) goto 20
      if(n.lt.0) goto 15
      write(4,'(1x,a,5x,a)') dnam(i),'- expected but not found'
      goto 50
15    write(4,'(1x,a,5x,a)') dnam(i),'- found but ignored'
      goto 50
20    if(n.gt.5) goto 40
      write(4,'(1x,a50,5i6            )') inam(i),(npos(i,j+1),j=1,n)
      goto 50
40    write(4,'(1x,a50,5i6,/,(51x,5i6))') inam(i),(npos(i,j+1),j=1,n)
50    continue
c
      write(4,'(//a,16(1h-),a/)') ' XTEXT names in dictionary ',
     * ' line numbers in XTEXT file -----------'
      do 100 i=1,mcnt-1
      n=npos(i,1)
      if(n.gt.0) goto 60
      if(n.lt.0) goto 55
      write(4,'(1x,a,5x,a)') dnam(i),'- expected but not found'
      goto 100
55    write(4,'(1x,a,5x,a)') dnam(i),'- found but ignored'
      goto 100
60    if(n.gt.5) goto 70
      write(4,'(a50,5i6            )') inam(i),(npos(i,j+1),j=1,n)
      goto 100
70    write(4,'(a50,5i6,/,(50x,5i6))') inam(i),(npos(i,j+1),j=1,n)
100   continue
c
cdbug write(6,'(i5,5x,a)') (bufn(i),defs(i),i=1,mdef+1)
      close(4)
      return
      end
c
c***************************************************************************
c     adddic - adds new dictionary tag to dnam() list.
c***************************************************************************
c
      subroutine adddic
      include 'xchek.cmn'
      integer i,j
      character nona*21
      data nona/',([{</|".?!;:)]}>/-=|'/
c
c---------------------------------------test if tag or duplicate
      if(name(1:1).ne.'_')           goto 100
      if(index(nona,name(2:2)).gt.0) goto 100
      do 40 i=1,ncnt
      if(name.eq.dnam(i)) goto 80
40    continue
c -------------------------------------- new tag add to list dnam()
      ncnt=ncnt+1
      if(ncnt.gt.maxnam) call err(1,'dictionary tags exceed 5000','')
      dnam(ncnt)=name
      inam(ncnt)=nami
      lnam(ncnt)=nchr-2
      if(d)write(6,'(a,a30)')'}}}}}}}}}}}} adddic   ',name
      do 60 j=1,100
60    npos(ncnt,j)=0
      goto 100
c
80    if(ddlv.ne.'2')  call err(1,'duplicate tag  ',name)
100   continue
cdbug write(6,'(2i3,2a40)') (i,lnam(i),inam(i),dnam(i),i=1,ncnt)
      return
      end
c
c***************************************************************************
c     import imports the dictionary definition blocks as designated
c     by the "_import" attributes .....
c
c     _import.scope - the flags indicting the nature of the import
c                        dic == all save frames in the source file
c                        cat == all save frames in the specific category
c                        grp == all save frames in the category & children
c                        def == save frame of one definition
c                        att == import attributes within a saveframe
c                        sta == import enumeration state list only
c                        val == import enumeration default value list only
c     _import.block   - identifier of the defn block to be imported
c     _import.file    - name (or uri) of the file containing the defn block
c     _import.if_dupl - flags of action taken if duplicate defn block found
c     _import.if_miss - flags of action taken if imported defn block missing
c
c     _import_list.id  == ((*.scope, *.block, *.file, *.if_dupl, *.if_miss))
c***************************************************************************
c
      subroutine import
      include 'xchek.cmn'
c
      integer ltyp(5)
      character*7 st
      character tag*60
      data st/'dcgdasv'/
c
      if(d)write(6,'(a,i5)')'>>>>>>>>>>>>>>>>>>>>> start import ',nfil
c
      impf=1
      noop=1
      if(loop.eq.0)    goto 70
c ----------------------------------------- get import values from loop
      ll=0
20    ll=ll+1
      if(stri(8:8).ne.'.')
     * call err(1,'import_list attribute in a loop',stri(1:nchr))
      if(stri(9:13).eq.'scope')      ltyp(ll)=1
      if(stri(9:13).eq.'block')      ltyp(ll)=2
      if(stri(9:12).eq.'file')       ltyp(ll)=3
      if(stri(9:15).eq.'if_dupl')    ltyp(ll)=4
      if(stri(9:15).eq.'if_miss')    ltyp(ll)=5
      call getstr
      if(ieof.gt.0) goto 1000
      if(type.eq.'name') goto 20
c
      if(type.ne.'char')
     * call err(1,'import attr value must be string',stri(1:nchr))
      if(ll.gt.6)
     * call err(1,'import attribute tags in loop > 5 ',stri(1:nchr))
c
      nimp=0
50    nimp=nimp+1
      l=0
55    l=l+1
      if(l.gt.ll) goto 50
      i=ltyp(l)
      if(i.eq.0)   goto 55
      tag=stri(2:nchr-1)
      call lcase(tag,impt(nimp,i),iiii)
      impn(nimp,i)=nchr-2
      call getstr
      if(ieof.gt.0)      goto 60
      if(type.eq.'char') goto 55
c
60    if(l.eq.ll) goto 80
      call err(1,'import attr value miscount in loop',stri(1:nchr))
c
c ------------------------------------------ get import values from tuple
c
70    if(stri(8:15).ne.'_list.id')
     * call err(1,"import attribute not recognised ",stri(1:nchr))
      call getval
c
c ---------------------------------------stack import requests per dic
80    loop=0
      do 85 i=1,nimp
      do 85 j=1,5
      dicn(nfil,i,j)=impn(i,j)
85    dict(nfil,i,j)=impt(i,j)
      ndic(nfil)=nimp
      mdic(nfil)=0
      if(d)write(6,'(a,i10,i5/(10x,a4,2a20,2a7))')' NEW IMPORT!!',
     *  nfil,nimp,((dict(nfil,j,k),k=1,5),j=1,nimp)
c
c -------------------------------------- process the current nfil level
100   if(nfil.le.0) goto 1000
      mdic(nfil)=mdic(nfil)+1
      if(mdic(nfil).gt.ndic(nfil)) goto 1000
c
      scop=dict(nfil,mdic(nfil),1)
      deft=dict(nfil,mdic(nfil),2)
      defn=dicn(nfil,mdic(nfil),2)
      filn=dict(nfil,mdic(nfil),3)
      dupl=dict(nfil,mdic(nfil),4)
      miss=dict(nfil,mdic(nfil),5)
      if(d) write(6,'(/a,i2,a,i2,5x,a4,2a20)')
     * ' apply import',mdic(nfil),' for nfil',nfil,
     * (dict(nfil,mdic(nfil),i),i=1,3)
      n=index(st,scop(1:1))
      if(n.eq.0) call err(1,"import scope unknown ",scop)
      cach=0
      if(n.gt.4) cach=1   
      call getdef
      goto 100
c
1000  continue
      if(d)write(6,'(a,i5)')'<<<<<<<<<<<<<<<<<<<<<  exit import ',nfil
      return
      end
c
c***************************************************************************
c     cache a definition line from ibuf into dbuf() for reuse.
c***************************************************************************
c
      subroutine cache
      include 'xchek.cmn'
c
      nbuf=nbuf+1
      if(nbuf.gt.2000) call err(1,'dbuf() defn cache exceeds limit','')
      dbuf(nbuf)(1:maxc)=ibuf(1:maxc)
      if(d)write(6,'(a,i5,5x,a50)') ' cache  @@@@@@',nbuf,ibuf
c
      return
      end
c
c***************************************************************************
c     getdef - extracts the definition identified by deft.
c    >>>>>>>>  ONLY used when importation in progress!!!!!!!!!
c     if the definition exists in the dbuf() cache use this.
c***************************************************************************
c
      subroutine getdef
      include 'xchek.cmn'
c
      character tag*60
c
      if(d)write(6,'(a,a30)')'===================== start getdef ',deft
c
      jtex=texf
      texf=0
      if(cach.eq.0) goto 50
c----------------------------------------------is import defn in dbuf()
      cach=0
      if(d)write(6,'(a,a)') ' searching cache for ',deft
      do 10 idef=1,mdef
      if(deft.eq.defs(idef)) goto 20
10    continue
      if(d)write(6,'(a,a)') '                 not found - add to cache'
      goto 50
20    do 25 i=bufn(idef)+2,bufn(idef+1)-2
25    call puttex(dbuf(i)(1:maxc))
      goto 815
c----------------------------------------------- match import block_id
50    n=dicn(nfil,mdic(nfil),2)
      call newfil
c
100   call getstr
      if(ieof.gt.0) goto 900
      if(type.ne.'save')           goto 100
      if(nchr.le.5)                goto 100
      tag=stri(5:nchr)
      call lcase(tag,tag,l)
      if(d)write(6,'(a,2i5,2(x,a20))')' !!!!!!!!!!! getdef',n,l,deft,tag
      if(scop.eq.'dic')            goto 200
      if(tag(1:l).eq.deft(1:n))    goto 150
      if(tag(2:l).eq.deft(1:n))    goto 150
      if(scop.eq.'def')            goto 100
      if(scop.eq.'cat')            goto 120
      if(scop.ne.'grp')            goto 100
120   if(tag(2:2).ne.deft(1:1))    goto 100
      if(tag(2:n+1).ne.deft(1:n))  goto 100
      if(scop.eq.'grp')            goto 150
      if(tag(n+2:n+2).eq.'_')      goto 100
c
150   ichr=maxc
c
c--------------------------------dic, cat, grp or def import?
      if(scop.eq.'cat') goto 200
      if(scop.eq.'grp') goto 200
      if(scop.ne.'def') goto 300
200   if(texf.eq.1)  call indxtx
      texf=jtex
c
220   call gettag
      if(d)write(6,'(i20,2i5,x,a,x,a)') nfil,cach,ieof,scop,type
      if(ieof.ne.0)      goto 800
      if(dicf.eq.0)      goto 230
      call adddic
      goto 260
230   if(type.eq.'save') goto 250
      goto 220
250   if(texf.eq.0) goto 260
      call puttex(ibuf)
      call indxtx
      texf=0
260   if(scop.eq.'def') goto 800
      goto 100
c
c-------------------------------- att, sta & val import?
c
c .......      first load import id into cache for later repeats
300   mdef=mdef+1
      if(mdef.gt.100) call err(1,'saved definitions >100',stri(1:nchr))
      idef=mdef
      bufn(idef)=nbuf+1
      defs(idef)=deft
      call cache
      cach=1
C
320   call gettag
      if(d)write(6,'(i20,2i5,x,a,x,a)') nfil,cach,ieof,scop,type
      if(ieof.ne.0)      goto 800
      if(type.ne.'save') goto 320
      bufn(idef+1)=nbuf+1
	  if(dicf.eq.1) goto 800
      do 360 i=bufn(idef)+2,bufn(idef+1)-2
360   call puttex(dbuf(i)(1:maxc))
c
c-----------------------------------close import file_id
800   if(nfil.le.0) goto 820
      cach=0
      close(ndev)
      if(h) write(6,'(15(1h-),a,i3)') ' close',ndev
      nfil=nfil-1
      if(nfil.le.0) goto 820
c
805   if(nhis.lt.0) goto 815
      nhis=nhis+1
      if(nfil.le.0.or.nhis.le.1) goto 815
      if(nhis.gt.100)call err(1,'import history table >100','')
      do 810 i=1,nfil
      do 810 j=1,5
810   hist(nhis,i,j)=hist(nhis-1,i,j)
c
815   continue
	  n=nfil-1
      if(n.le.0) goto 819
	  m=mdic(n)
      if(d)   write(6,'(i5,5a9)') n,(dict(n,m,i),i=1,5)
      if(d)   write(6,'(i5,5i9)') m,(dicn(n,m,i),i=1,5)
      scop=dict(n,m,1)
      deft=dict(n,m,2)
      defn=dicn(n,m,2)
      filn=dict(n,m,3)
      dupl=dict(n,m,4)
      miss=dict(n,m,5)
819   ndev=devn(nfil)
820   ieof=0
      texf=jtex
      if(nfil.le.1) impf=0
CCCCC noop=0
      ibuf=lbuf(nfil)
      goto 1000
c
900   if(scop.eq.'cat') goto 800
      if(scop.eq.'grp') goto 800
      if(scop.eq.'dic') goto 800
      if(miss.eq.'ignore') goto 800
      call err(1,'import definition not found ',deft)
1000  continue
      if(d)write(6,'(a,a30)')'=====================  exit getdef ',deft
      return
      end
c
c***************************************************************************
c     getval saves values of the import attributes in a ((....))
c***************************************************************************
c
      subroutine getval
      include 'xchek.cmn'
c
      integer jchr,narg,star(5),stop(5),len
      character c*1, tag*60
c
      jchr=0
      nimp=0
      narg=1
      do 10 i=1,5
      star(i)=0
10    stop(i)=0
c     --------------------------------------- read the values ((...)) 
      call getstr
      if(ieof.gt.0)         goto 500
      if(type.ne.'list')
     * call err(1,'import attributes expected in tuple()',stri(1:nchr))
c     --------------------------------------- strip out the list arguments
50    jchr=jchr+1
      if(jchr.gt.nlis)      goto 200
      c=list(jchr:jchr)
cdbug write(6,'(a,x,9i3)') c,narg,star,stop
      if(c.eq.")")   goto 200
      if(c.eq."'")   goto 100
      if(c.ne.'"')   goto 50
100   if(star(narg).ne.0) goto 110
      star(narg)=jchr+1
      goto 50
110   stop(narg)=jchr-1
      narg=narg+1
      goto 50
c     --------------------------------------- store import arguments
200   if(narg.eq.1) goto 500
      if(narg.lt.3)call err(1,'illegal import construction',list)
      nimp=nimp+1
      if(narg.lt.5) impt(nimp,4)='exit'
      if(narg.lt.5) impn(nimp,4)=3
      if(narg.lt.6) impt(nimp,5)='exit'
      if(narg.lt.6) impn(nimp,5)=3
      do 210 i=1,narg-1
      impt(nimp,i)=list(star(i):stop(i))
      impn(nimp,i)=stop(i)-star(i)+1
      star(i)=0
210   stop(i)=0
      narg=1
      call lcase(impt(nimp,1),impt(nimp,1),len)
      call lcase(impt(nimp,2),impt(nimp,2),len)
cdbug write(6,'(i5,x,a)') nlis,list
cdbug write(6,'(i3,x,5(a10,i3))') nimp,(impt(nimp,i),impn(nimp,i),i=1,5)
      if(jchr.lt.nlis)  goto 50
c
500   continue
      return
      end
c
c***************************************************************************
c     gettag - gets tags placing them in 'name' and 'nami'
c***************************************************************************
c
      subroutine gettag
c
      include 'xchek.cmn'
      integer i
      character c*1
c
      if(d)write(6,'(a,5i5)')'***start gettag',texf,savf,dicf,impf
c
10    call getstr
      if(ieof.ne.0)  goto 100
cdbug write(6,'(2i5,3(x,a))') nfil,iatt,ddlv,type,stri(1:nchr)
c
      if(type.ne.'name')  goto 40
      if(ddlv.ne.' ')     goto 20
c                                               extract the ddl version
      if(stri(1:11).ne.'_dictionary') goto 20
      if(stri(12:16).ne.'_name') goto 12
      ddlv='1'
      goto 20
12    if(stri(12:16).ne.'.data') goto 14
      ddlv='2'
      goto 20
14    if(stri(12:16).ne.'.clas') goto 20
      ddlv='3'
c
c  -------------------------set iatt: 1,2,3 tag names; 4,5 aliases
20    if(iatt.gt.0)   goto 40
      if(ddlv.ne.'1') goto 25
      if(stri(1:nchr).ne.'_name')          goto 10
      iatt=1
      goto 10
25    if(ddlv.ne.'2') goto 30
      if(stri(1:nchr).ne.'_item.name')     goto 27
      iatt=2
27    if(stri(1:13).ne.'_item_aliases')    goto 10
      iatt=5
      goto 10
30    if(ddlv.ne.'3') goto 40
      if(stri(2:7).ne.'import')            goto 32
      if(savf.eq.0.or.dicf.eq.0) call import
32    if(type.ne.'name')                   goto 10
      if(stri(1:nchr).ne.'_definition.id') goto 35
      iatt=3
35    if(stri(1:nchr).ne.'_alias.definition_id') goto 10
      iatt=4
      goto 10
c
c  -------------------------- iatt set; grab tag or trailing save
40    continue
      if(texf.eq.1.and.scop.eq.'dic')    goto 44
      if(cach.eq.1)        goto 42
      if(texf.eq.0)        goto 45
42    if(stri(1:nchr).eq.'save_') goto 100
44    iatt=0
      goto 10
c  
45    if(iatt.gt.0)        goto 50
c         
      if(nchr.lt.4)        goto 10
      if(ddlv.ne.'2')      goto 10
      if(type.eq.'char')   goto 60
      if(type.ne.'name')   goto 10
      iatt=0
      goto 10
c                                          test for alias names
50    if(iatt.lt.4)       goto 60
      if(type.ne.'name')  goto 10
      goto 61
c
60    if(stri(2:2).eq.'_') goto 62
61    iatt=0
      goto 10
c
62    if(nchr.gt.62)call err(0,'dictionary data name > 60 chars',
     *        stri(2:nchr-1))
      if(stri(nchr-2:nchr-1).eq."[]") goto 10
      nami=stri(2:nchr-1)
      call lcase(nami,name,l)
cdbuf write(6,'(5x,2i5,5x,2a40)') iatt,nchr,nami,name
      if(ddlv.ne.'1') iatt=0
c
100   continue
      if(d)write(6,'(a,5i5)')'*** exit gettag',texf,savf,dicf,impf
      return
      end
c
c***************************************************************************
c     indxtx indexes tags in XTEXT into tag1() tag2() tadn() tagh() arrays
c***************************************************************************
      subroutine indxtx
      include 'xchek.cmn'
c
      if(nchr.eq.5) goto 100
      ntag=ntag+1
      tagn(ntag)=stri(6:nchr)
      tag1(ntag)=ntex+1
      tagl(ntag)=nfil
      tagh(ntag)=nhis
100   continue
cdbug write(6,'(4i5,x,a)') ntag,nfil,nhis,ntex,tagn(ntag)
      tag2(ntag)=ntex+1
      return
      end
c
c***************************************************************************
c     error message generator. output to device 6 and stop.
c***************************************************************************
      subroutine err(i,mess,strg)
      include 'xchek.cmn'
      integer i
c
      character*(*) mess,strg
c
      write(*,'(11h error >>> ,a,2x,a)') mess,strg
      if(i.eq.2) goto 20
      write(*,'(11x,a,i5,3x,a)') 'at line',line(nfil),filn
      if(i.eq.0) return
      stop
20    write(*,'(11x,a,i5)') 'in XTEMP at import table level', nfil
50    stop
      end
c
c***************************************************************************
c     lcase converts strings to lower case characters.
c***************************************************************************
c
      subroutine lcase(strin,strot,l)
      include 'xchek.cmn'
      character strin*60,strot*60,c*1
      integer n,l
c
      n=0
      l=0
10    n=n+1
      if(n.gt.60) goto 100
      c=strin(n:n)
      if(c.ne.' ')  goto 15
      strot(n:n)=' '
      goto 10
15    l=l+1
      if(c.ge.'A'.and.c.le.'Z') goto 20
      strot(n:n)=c
      goto 10
20    strot(n:n)=char(ichar(c)+case)
      goto 10
100   return
      end
c
c***************************************************************************
c     newfil opens a new dictionary file into the stack indexed by nfil.
c***************************************************************************
      subroutine newfil
      include 'xchek.cmn'
c                                save ip buf of current file
      if(nfil.gt.0) lbuf(nfil)=ibuf
      savf=0
c                                store import history if INTEX
      if(nhis.lt.0) goto 50
      nhis=nhis+1
      if(nfil.eq.0.or.nhis.eq.1) goto 30
      if(nhis.gt.100)call err(1,'import history table >100','')
      do 20 i=1,nfil
      do 20 j=1,5
20    hist(nhis,i,j)=hist(nhis-1,i,j)
30    if(nfil+1.gt.25) call err(1,'dict file import stack > 25','')
      hist(nhis,nfil+1,1)=scop
      hist(nhis,nfil+1,2)=deft
      hist(nhis,nfil+1,3)=filn
      hist(nhis,nfil+1,4)=dupl
      hist(nhis,nfil+1,5)=miss
c
50    nfil=nfil+1
      if(nfil.gt.mfil) mfil=nfil
      ndev=devn(nfil)
      open(ndev,file=filn,status='old',form='formatted')
      line(nfil)=0
      ichr=maxc
      ieof=0
      if(h) write(6,'(15(1h-),a,i4,x,a20,a30)')' open',ndev,filn,deft
      return
      end
c
c***************************************************************************
c     puttex writes a line into the temporary expanded text file.
c***************************************************************************
      subroutine puttex(buf)
      include 'xchek.cmn'
c
      character*125 buf
c
      ntex=ntex+1
      write(7,'(a)') buf
      if(d)write(6,'(a,i5,2i3,x,a)')
     * ' puttex ++++++', ntex,savf,loop,buf(1:60)
      return
      end
c
c***************************************************************************
c     readln reads a line from the current file (nfil) on device ndev
c     the line is cached in dbuf() if it is imported att, sta or val.
c***************************************************************************
      subroutine readln
      include 'xchek.cmn'
c
c     -------------------------------------- output prev buffer to XTEXT
Cdbg  write(6,'(a,5i5)')'%%%%% readln   ',texf,impf,savf,noop,cach
      if(impf.eq.1.and.savf.eq.0) goto 50
      if(texf.eq.1.and.noop.eq.0) call puttex(ibuf(1:maxc))
      if(noop.eq.0.and.stri(1:nchr).eq.'save_') savf=0
c     ------------------------------------------- read a new line
50    noop=0
      read(ndev,'(a)',end=100)     ibuf(1:maxc)
	  if(r)write(6,'(a,i2,a,a70)')'read',nfil,'.....',ibuf
      if(cach.eq.1) call cache
c     ------------------------------------------- count a new line
      line(nfil)=line(nfil)+1
      ichr=1
      goto 200
c
100   ieof=1
200   return
      end
c
c***************************************************************************
c     getstr extract a string of characters delimited by blanks, tabs, quotes.
c***************************************************************************
      subroutine getstr
      include 'xchek.cmn'
c
      integer       i,lbra
      character c*1,num*13,temp*125
      data num/'0123456789+-.'/
c
c---------------------------------- incr char on current line
10    ichr=ichr+1
      if(ichr.le.maxc)     goto 30
c---------------------------------- get a new line from device ndev
20    call readln
      if(ieof.ne.0) goto 300
c---------------------------------- are text lines to be skipped
      if(audf.eq.0)        goto 30
      if(ibuf(1:1).ne.';') goto 30
25    call readln
      if(ieof.ne.0) goto 300
      if(ibuf(1:1).ne.';') goto 25
      goto 10
c---------------------------------- test for delimiter character
30    c=ibuf(ichr:ichr)
      if(c.eq.' ')       goto 10
      if(c.eq.tab)       goto 10
      if(c.eq.'#')       goto 20
      if(c.eq.'''')      goto 60
      if(c.eq.'"')       goto 60
      if(c.eq.'[')       goto 70
      if(c.eq.'(')       goto 70
c---------------------------------- test for data name
      if(c.ne.'_')       goto 40
      type='name'
      goto 45
c---------------------------------- test for number or character data
40    type='numb'
      if(index(num,c).eq.0) type='char'
c---------------------------------- get blank-limited char string
45    do 50 i=ichr,maxc
      if(ibuf(i:i).eq.' ')       goto 90
      if(ibuf(i:i).eq.tab)       goto 90
50    continue
      i=maxc+1
      goto 90
c---------------------------------- get quote-limited char string
60    type='char'
      do 65 i=ichr+1,maxc
      if(ibuf(i:i).eq.c)         goto 68
65    continue
      if(dicf.eq.1)
     * call err(0,'quoted string not closed',ibuf(ichr:maxc))
      i=maxc
      ibuf(i:i)=c
68    i=i+1
      goto 90
c---------------------------------- get brackets-limited string
70    type='list'
      lbra=1
      nlis=1
72    do 76 i=ichr+1,maxc
      if(ibuf(i:i).eq.')')  goto 73
      if(ibuf(i:i).ne.']')  goto 74
73    lbra=lbra-1
      if(lbra.eq.0)         goto 85
74    if(ibuf(i:i).eq.'(')  goto 75
      if(ibuf(i:i).ne.'[')  goto 76
75    lbra=lbra+1
76    continue
c                                 list not closed yet; try next line
78    n=nlis+i-ichr
      if(n.gt.2000) call err(1,'tuple exceeds 2000 char','')
      list(nlis:n)=ibuf(ichr+1:i-1)
      nlis=n+1
      noop=1
      call readln
      if(ieof.ne.0) goto 300
      ichr=0
      goto 72
c                                 list has closed; store in list
85    n=nlis+i-ichr
      noop=1
      if(n.gt.2000) call err(1,'tuple exceeds 2000 char','')
      list(nlis:n)=ibuf(ichr+1:i-1)
      nlis=n+1
      i=i+1
c---------------------------------- count & store string
90    nchr=i-ichr
      ichr=i-1
      stri(1:nchr)=ibuf(i-nchr:ichr)
c----------------------------------- test if char str is save_
      if(stri(1:5).ne.'save_') goto 100
      type='save'
      if(nchr.gt.5) savf=1
      if(texf.eq.1) call indxtx
      goto 400
c----------------------------------- test if char str is loop_
100   if(stri(1:5).ne.'loop_') goto 400
      type='loop'
	  temp=ibuf
	  noop=1
      goto 400
c
c-----------------------------------eof encountered 
300   continue
      if(nfil.gt.1) goto 400
c                                  only the parent file can exit
c                                  all others must exit by caller
      close(ndev)
      if(h) write(6,'(15(1h%),a,i3/)') ' close',ndev
      nfil=nfil-1
	  ichr=maxc
      noop=0
	  goto 500
c ------------------ check if loop_ in previous buffered line
400   continue
      if(loop.ne.1.or.type.ne.'name'.or.texf.eq.0) goto 420
      if(impf.eq.1.and.savf.eq.0) goto 420
ccccc  write(7,'(a,i3)') '@@@@@',loop
      if(stri(2:7).ne.'import') call puttex(temp(1:maxc))
	  loop=2
420   if(type.ne.'name') loop=0
      if(type.eq.'loop') loop=1
c
      if(s)write(6,'(a,5i3,x,a,x,a)') 
     * 'getstr::::', texf,savf,dicf,impf,loop,type,stri(1:nchr)
c
500   continue
      return
      end
