1module m_common_element
2
3#ifndef DUMMYLIB
4  ! Structure and manipulation of element specification
5
6  use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc
7  use fox_m_fsys_string_list, only: string_list, init_string_list, &
8    destroy_string_list, add_string, tokenize_to_string_list, &
9    registered_string
10  use m_common_charset, only: isInitialNameChar, isNameChar, &
11    upperCase, XML_WHITESPACE
12  use m_common_content_model, only: content_particle_t, newCP, destroyCPtree, &
13    OP_MIXED, OP_CHOICE, OP_SEQ, OP_NAME, &
14    REP_QUESTION_MARK, REP_ASTERISK, &
15    transformCPPlus ! , dumpCPtree ! For debugging - see below.
16  use m_common_error, only: error_stack, add_error, in_error
17  use m_common_namecheck, only: checkName, checkNames, checkNCName, &
18    checkNCNames, checkQName, checkNmtoken, checkNmtokens
19
20  implicit none
21  private
22
23  integer, parameter :: ST_START               = 0
24  integer, parameter :: ST_EMPTYANY            = 1
25  integer, parameter :: ST_FIRSTCHILD          = 2
26  integer, parameter :: ST_END                 = 3
27  integer, parameter :: ST_PCDATA              = 4
28  integer, parameter :: ST_NAME                = 5
29  integer, parameter :: ST_CHILD               = 6
30  integer, parameter :: ST_AFTERBRACKET        = 7
31  integer, parameter :: ST_AFTERLASTBRACKET    = 8
32  integer, parameter :: ST_SEPARATOR           = 9
33  integer, parameter :: ST_AFTERNAME           = 10
34  integer, parameter :: ST_ATTTYPE             = 11
35  integer, parameter :: ST_AFTER_NOTATION      = 12
36  integer, parameter :: ST_NOTATION_LIST       = 13
37  integer, parameter :: ST_ENUMERATION         = 14
38  integer, parameter :: ST_ENUM_NAME           = 15
39  integer, parameter :: ST_AFTER_ATTTYPE_SPACE = 16
40  integer, parameter :: ST_AFTER_ATTTYPE       = 17
41  integer, parameter :: ST_DEFAULT_DECL        = 18
42  integer, parameter :: ST_AFTERDEFAULTDECL    = 19
43  integer, parameter :: ST_DEFAULTVALUE        = 20
44
45  integer, parameter :: ATT_NULL = 0
46
47  integer, parameter :: ATT_CDATA = 1
48  integer, parameter :: ATT_ID = 2
49  integer, parameter :: ATT_IDREF = 3
50  integer, parameter :: ATT_IDREFS = 4
51  integer, parameter :: ATT_ENTITY = 5
52  integer, parameter :: ATT_ENTITIES = 6
53  integer, parameter :: ATT_NMTOKEN = 7
54  integer, parameter :: ATT_NMTOKENS = 8
55  integer, parameter :: ATT_NOTATION = 9
56  integer, parameter :: ATT_ENUM = 10
57  integer, parameter :: ATT_CDANO = 11
58  integer, parameter :: ATT_CDAMB = 12
59
60  character(len=8), parameter :: ATT_TYPES(12) = (/ &
61    "CDATA   ", &
62    "ID      ", &
63    "IDREF   ", &
64    "IDREFS  ", &
65    "ENTITY  ", &
66    "ENTITIES", &
67    "NMTOKEN ", &
68    "NMTOKENS", &
69    "NOTATION", &
70    "ENUM    ", &
71    "CDANO   ", &
72    "CDAMB   "/)
73
74  integer, parameter :: ATT_REQUIRED = 1
75  integer, parameter :: ATT_IMPLIED = 2
76  integer, parameter :: ATT_DEFAULT = 4
77  integer, parameter :: ATT_FIXED = 3
78
79
80  type attribute_t
81    character, pointer :: name(:) => null()
82    integer :: attType = ATT_NULL
83    integer :: attDefault = ATT_NULL
84    type(string_list) :: enumerations
85    character, pointer :: default(:) => null()
86    logical :: internal = .true.
87  end type attribute_t
88
89  type attribute_list
90    type(attribute_t), pointer :: list(:) => null()
91  end type attribute_list
92
93  type element_t
94    character, pointer :: name(:) => null()
95    logical :: empty = .false.
96    logical :: any = .false.
97    logical :: mixed = .false.
98    logical :: id_declared = .false.
99    logical :: internal = .true.
100    type (content_particle_t), pointer :: cp => null()
101    character, pointer :: model(:) => null()
102    type(attribute_list) :: attlist
103  end type element_t
104
105  type element_list
106    type(element_t), pointer :: list(:) => null()
107  end type element_list
108
109
110  public :: element_t
111  public :: element_list
112
113  public :: attribute_t
114  public :: attribute_list
115
116  public :: init_element_list
117  public :: destroy_element_list
118  public :: existing_element
119  public :: declared_element
120  public :: get_element
121  public :: add_element
122
123  public :: parse_dtd_element
124
125  public :: init_attribute_list
126  public :: destroy_attribute_list
127
128
129  public :: parse_dtd_attlist
130
131  public :: report_declarations
132
133  public :: attribute_has_default
134  public :: get_attlist_size
135  public :: get_attribute_declaration
136  public :: express_attribute_declaration
137
138  public :: att_value_normalize
139
140  public :: get_att_type_enum
141
142  public :: ATT_NULL
143  public :: ATT_CDATA
144  public :: ATT_ID
145  public :: ATT_IDREF
146  public :: ATT_IDREFS
147  public :: ATT_ENTITY
148  public :: ATT_ENTITIES
149  public :: ATT_NMTOKEN
150  public :: ATT_NMTOKENS
151  public :: ATT_NOTATION
152  public :: ATT_ENUM
153
154  public :: ATT_CDANO
155  public :: ATT_CDAMB
156
157  public :: ATT_REQUIRED
158  public :: ATT_IMPLIED
159  public :: ATT_DEFAULT
160  public :: ATT_FIXED
161
162  public :: ATT_TYPES
163
164  interface get_attribute_declaration
165    module procedure get_attdecl_by_index
166    module procedure get_attdecl_by_name
167  end interface
168
169contains
170
171  subroutine init_element_list(e_list)
172    type(element_list), intent(inout) :: e_list
173
174    allocate(e_list%list(0))
175  end subroutine init_element_list
176
177  subroutine destroy_element_list(e_list)
178    type(element_list), intent(inout) :: e_list
179
180    integer :: i
181
182    do i = 1, size(e_list%list)
183      deallocate(e_list%list(i)%name)
184      if (associated(e_list%list(i)%cp)) call destroyCPtree(e_list%list(i)%cp)
185      if (associated(e_list%list(i)%model)) deallocate(e_list%list(i)%model)
186      call destroy_attribute_list(e_list%list(i)%attlist)
187    enddo
188    deallocate(e_list%list)
189  end subroutine destroy_element_list
190
191  function existing_element(e_list, name) result(p)
192    type(element_list), intent(in) :: e_list
193    character(len=*), intent(in) :: name
194    logical :: p
195
196    integer :: i
197
198    p = .false.
199    do i = 1, size(e_list%list)
200      if (str_vs(e_list%list(i)%name)==name) then
201        p = .true.
202        exit
203      endif
204    enddo
205  end function existing_element
206
207  function declared_element(e_list, name) result(p)
208    type(element_list), intent(in) :: e_list
209    character(len=*), intent(in) :: name
210    logical :: p
211
212    integer :: i
213
214    p = .false.
215    do i = 1, size(e_list%list)
216      if (str_vs(e_list%list(i)%name)==name) then
217        p = associated(e_list%list(i)%model)
218        exit
219      endif
220    enddo
221  end function declared_element
222
223  function get_element(e_list, name) result(e)
224    type(element_list), intent(in) :: e_list
225    character(len=*), intent(in) :: name
226    type(element_t), pointer :: e
227
228    integer :: i
229
230    do i = 1, size(e_list%list)
231      if (str_vs(e_list%list(i)%name)==name) then
232        e => e_list%list(i)
233        return
234      endif
235    enddo
236    e => null()
237  end function get_element
238
239  function add_element(e_list, name) result(e)
240    type(element_list), intent(inout) :: e_list
241    character(len=*), intent(in) :: name
242    type(element_t), pointer :: e
243
244    type(element_t), pointer :: temp(:)
245    integer :: i
246
247    temp => e_list%list
248
249    allocate(e_list%list(size(temp)+1))
250    do i = 1, size(temp)
251      e_list%list(i)%name => temp(i)%name
252      e_list%list(i)%model => temp(i)%model
253      e_list%list(i)%empty = temp(i)%empty
254      e_list%list(i)%any = temp(i)%any
255      e_list%list(i)%mixed = temp(i)%mixed
256      e_list%list(i)%cp => temp(i)%cp
257      e_list%list(i)%id_declared = temp(i)%id_declared
258      e_list%list(i)%internal = temp(i)%internal
259      e_list%list(i)%attlist%list => temp(i)%attlist%list
260    enddo
261    deallocate(temp)
262    e => e_list%list(i)
263    e%name => vs_str_alloc(name)
264    call init_attribute_list(e%attlist)
265
266  end function add_element
267
268  subroutine parse_dtd_element(contents, xv, stack, element, internal)
269    character(len=*), intent(in) :: contents
270    integer, intent(in) :: xv
271    type(error_stack), intent(inout) :: stack
272    type(element_t), pointer :: element
273    logical, intent(in) :: internal
274
275    integer :: state
276    integer :: i, nbrackets
277    logical :: mixed, empty, any
278    character :: c
279    character, pointer :: order(:), name(:), temp(:)
280    type(content_particle_t), pointer :: top, current, tcp
281    logical :: mixed_additional, firstChild
282
283    ! FIXME should we check namespaces here (for element names)
284    ! checking duplicates - valid or wf? - and only for MIXED?
285
286    order => null()
287    name => null()
288    temp => null()
289
290    any = .false.
291    empty = .false.
292    mixed = .false.
293    nbrackets = 0
294    mixed_additional = .false.
295    firstChild = .true.
296    state = ST_START
297
298    top => null()
299
300    do i = 1, len(contents) + 1
301      if (i<=len(contents)) then
302        c = contents(i:i)
303      else
304        c = ' '
305      endif
306
307      if (state==ST_START) then
308        !write(*,*)'ST_START'
309        if (verify(c, XML_WHITESPACE)==0) then
310          continue
311        elseif (verify(c, 'EMPTYANY')==0) then
312          name => vs_str_alloc(c)
313          state = ST_EMPTYANY
314        elseif (c=='(') then
315          order => vs_str_alloc(" ")
316          nbrackets = 1
317          top => newCP()
318          current => top
319          state = ST_FIRSTCHILD
320        else
321          call add_error(stack, &
322            'Unexpected character "'//c//'" at start of ELEMENT specification')
323          goto 100
324        endif
325
326      elseif (state==ST_EMPTYANY) then
327        !write(*,*)'ST_EMPTYANY'
328        if (verify(c, upperCase)==0) then
329          temp => name
330          name => vs_str_alloc(str_vs(temp)//c)
331          deallocate(temp)
332        elseif (verify(c, XML_WHITESPACE)==0) then
333          if (str_vs(name)=='EMPTY') then
334            empty = .true.
335            top => newCP(empty=.true.)
336            current => top
337          elseif (str_vs(name)=='ANY') then
338            any = .true.
339            top => newCP(any=.true.)
340            current => top
341          else
342            call add_error(stack, &
343              'Unexpected ELEMENT specification; expecting EMPTY or ANY')
344            goto 100
345          endif
346          deallocate(name)
347          state = ST_END
348        else
349          call add_error(stack, &
350            'Unexpected ELEMENT specification; expecting EMPTY or ANY')
351          goto 100
352        endif
353
354      elseif (state==ST_FIRSTCHILD) then
355        !write(*,*)'ST_FIRSTCHILD'
356        if (verify(c, XML_WHITESPACE)==0) cycle
357        if (c=='#') then
358          mixed = .true.
359          state = ST_PCDATA
360          name => vs_str_alloc("")
361        elseif (isInitialNameChar(c, xv)) then
362          allocate(name(1))
363          name(1) = c
364          state = ST_NAME
365        elseif (c=='(') then
366          nbrackets = nbrackets + 1
367          deallocate(order)
368          tcp => newCP()
369          current%firstChild => tcp
370          tcp%parent => current
371          current => tcp
372          order => vs_str_alloc("  ")
373          state = ST_CHILD
374        else
375          call add_error(stack, &
376            'Unexpected character in ELEMENT specification')
377          goto 100
378        endif
379
380      elseif (state==ST_PCDATA) then
381        !write(*,*)'ST_PCDATA'
382        if (verify(c, 'PCDATA')==0) then
383          temp => name
384          name => vs_str_alloc(str_vs(temp)//c)
385          deallocate(temp)
386        elseif (verify(c, XML_WHITESPACE)==0) then
387          if (str_vs(name)=='PCDATA') then
388            deallocate(name)
389          else
390            call add_error(stack, &
391              'Unexpected token after #')
392            goto 100
393          endif
394          ! Must be first child
395          current%operator = OP_MIXED
396          tcp => newCP(name="#PCDATA")
397          current%firstChild => tcp
398          tcp%parent => current
399          current => tcp
400          firstChild = .false.
401          state = ST_SEPARATOR
402        elseif (c==')') then
403          if (str_vs(name)=='PCDATA') then
404            deallocate(name)
405            nbrackets = 0
406            state = ST_AFTERLASTBRACKET
407            deallocate(order)
408          else
409            call add_error(stack, &
410              'Unexpected token after #')
411            goto 100
412          endif
413          ! Must be first child
414          current%operator = OP_MIXED
415          tcp => newCP(name="#PCDATA")
416          current%firstChild => tcp
417          tcp%parent => current
418          firstChild = .false.
419        elseif (c=='|') then
420          if (str_vs(name)=='PCDATA') then
421            firstChild = .false.
422            deallocate(name)
423          else
424            call add_error(stack, &
425              'Unexpected token after #')
426            goto 100
427          endif
428          ! Must be first child
429          current%operator = OP_MIXED
430          tcp => newCP(name="#PCDATA")
431          current%firstChild => tcp
432          tcp%parent => current
433          current => tcp
434          firstChild = .false.
435          order(1) = '|'
436          state = ST_CHILD
437        elseif (c==',') then
438          call add_error(stack, &
439            'Ordered specification not allowed for Mixed elements')
440          goto 100
441        else
442          call add_error(stack, &
443            'Unexpected character in ELEMENT specification')
444          goto 100
445        endif
446
447      elseif (state==ST_NAME) then
448        !write(*,*)'ST_NAME'
449        if (isNameChar(c, xv)) then
450          temp => name
451          name => vs_str_alloc(str_vs(temp)//c)
452          deallocate(temp)
453        elseif (scan(c, "?+*")>0) then
454          if (mixed) then
455            call add_error(stack, &
456              'Repeat operators forbidden for Mixed elements')
457            goto 100
458          endif
459          tcp => newCP(name=str_vs(name), repeat=c)
460          deallocate(name)
461          if (firstChild) then
462            current%firstChild => tcp
463            tcp%parent => current
464            firstChild = .false.
465          else
466            current%nextSibling => tcp
467            tcp%parent => current%parent
468          endif
469          current => tcp
470          if (c=="+") call transformCPPlus(current)
471          state = ST_SEPARATOR
472        elseif (verify(c, XML_WHITESPACE)==0) then
473          if (mixed) mixed_additional = .true.
474          tcp => newCP(name=str_vs(name))
475          deallocate(name)
476          if (firstChild) then
477            current%firstChild => tcp
478            tcp%parent => current
479            firstChild = .false.
480          else
481            current%nextSibling => tcp
482            tcp%parent => current%parent
483          endif
484          current => tcp
485          state = ST_SEPARATOR
486        elseif (scan(c,',|')>0) then
487          if (order(nbrackets)=='') then
488            order(nbrackets)=c
489          elseif (order(nbrackets)/=c) then
490            call add_error(stack, &
491              'Cannot mix ordered and unordered elements')
492            goto 100
493          endif
494          if (mixed) mixed_additional = .true.
495          tcp => newCP(name=str_vs(name))
496          deallocate(name)
497          if (firstChild) then
498            current%firstChild => tcp
499            tcp%parent => current
500            firstChild = .false.
501          else
502            current%nextSibling => tcp
503            tcp%parent => current%parent
504          endif
505          current => tcp
506          if (c=="|".and.current%parent%operator/=OP_MIXED) &
507            current%parent%operator = OP_CHOICE
508          state = ST_CHILD
509        elseif (c==')') then
510          if (mixed) mixed_additional = .true.
511          nbrackets = nbrackets - 1
512          if (nbrackets==0) then
513            state = ST_AFTERLASTBRACKET
514            deallocate(order)
515          else
516            temp => order
517            allocate(order(nbrackets))
518            order = temp(:size(order))
519            deallocate(temp)
520            state = ST_AFTERBRACKET
521          endif
522          tcp => newCP(name=str_vs(name))
523          deallocate(name)
524          if (firstChild) then
525            current%firstChild => tcp
526            tcp%parent => current
527            firstChild = .false.
528          else
529            current%nextSibling => tcp
530            tcp%parent => current%parent
531            current => current%parent
532            if (.not.check_duplicates(current)) &
533              goto 100
534          endif
535        else
536          call add_error(stack, &
537            'Unexpected character found after element name')
538          goto 100
539        endif
540
541      elseif (state==ST_CHILD) then
542        !write(*,*)'ST_CHILD'
543        if (verify(c, XML_WHITESPACE)==0) cycle
544        if (c=='#') then
545          call add_error(stack, &
546            '# forbidden except as first child element')
547          goto 100
548        elseif (isInitialNameChar(c, xv)) then
549          name => vs_str_alloc(c)
550          state = ST_NAME
551        elseif (c=='(') then
552          if (mixed) then
553            call add_error(stack, &
554              'Nested brackets forbidden for Mixed content')
555            goto 100
556          endif
557          tcp => newCP()
558          if (firstChild) then
559            current%firstChild => tcp
560            tcp%parent => current
561          else
562            current%nextSibling => tcp
563            tcp%parent => current%parent
564            firstChild = .true.
565          endif
566          current => tcp
567          nbrackets = nbrackets + 1
568          temp => order
569          order => vs_str_alloc(str_vs(temp)//" ")
570          deallocate(temp)
571        else
572          call add_error(stack, &
573            'Unexpected character "'//c//'" found after (')
574          goto 100
575        endif
576
577      elseif (state==ST_SEPARATOR) then
578        !write(*,*)'ST_SEPARATOR'
579        if (verify(c, XML_WHITESPACE)==0) cycle
580        if (c=='#') then
581          call add_error(stack, &
582            '#PCDATA must be first in list')
583          goto 100
584        elseif (scan(c,'|,')>0) then
585          if (order(nbrackets)=='') then
586            order(nbrackets) = c
587          elseif (order(nbrackets)/=c) then
588            call add_error(stack, &
589              'Cannot mix ordered and unordered elements')
590            goto 100
591          endif
592          if (c=="|".and.current%parent%operator/=OP_MIXED) &
593            current%parent%operator = OP_CHOICE
594          state = ST_CHILD
595        elseif (c==')') then
596          nbrackets = nbrackets - 1
597          if (nbrackets==0) then
598            state = ST_AFTERLASTBRACKET
599            deallocate(order)
600          else
601            temp => order
602            allocate(order(nbrackets))
603            order = temp(:size(order))
604            deallocate(temp)
605            state = ST_AFTERBRACKET
606          endif
607          current => current%parent
608          if (.not.check_duplicates(current)) &
609            goto 100
610        else
611          call add_error(stack, &
612            'Unexpected character found in element declaration.')
613          goto 100
614        endif
615
616      elseif (state==ST_AFTERBRACKET) then
617        !write(*,*)'ST_AFTERBRACKET'
618        if (c=='*') then
619          current%repeater = REP_ASTERISK
620          state = ST_SEPARATOR
621        elseif (c=='+') then
622          call transformCPPlus(current)
623          state = ST_SEPARATOR
624        elseif (c=='?') then
625          current%repeater = REP_QUESTION_MARK
626          state = ST_SEPARATOR
627        elseif (verify(c, XML_WHITESPACE)==0) then
628          state = ST_SEPARATOR
629        elseif (scan(c,'|,')>0) then
630          if (order(nbrackets)=='') then
631            order(nbrackets) = c
632          elseif (order(nbrackets)/=c) then
633            call add_error(stack, &
634              'Cannot mix ordered and unordered elements')
635            goto 100
636          endif
637          if (c=="|".and.current%parent%operator/=OP_MIXED) &
638            current%parent%operator = OP_CHOICE
639          state = ST_CHILD
640        elseif (c==')') then
641          nbrackets = nbrackets - 1
642          if (nbrackets==0) then
643            deallocate(order)
644            state = ST_AFTERLASTBRACKET
645          else
646            temp => order
647            allocate(order(nbrackets))
648            order = temp(:size(order))
649            deallocate(temp)
650            state = ST_AFTERBRACKET
651          endif
652          current => current%parent
653          if (.not.check_duplicates(current)) &
654            goto 100
655        else
656          call add_error(stack, &
657            'Unexpected character "'//c//'"found after ")"')
658          goto 100
659        endif
660
661      elseif (state==ST_AFTERLASTBRACKET) then
662        !write(*,*)'ST_AFTERLASTBRACKET'
663        if (c=='*') then
664          state = ST_END
665          current%repeater = REP_ASTERISK
666        elseif (c=='+') then
667          if (mixed) then
668            call add_error(stack, &
669              '+ operator disallowed for Mixed elements')
670            goto 100
671          endif
672          call transformCPPlus(current)
673          state = ST_END
674        elseif (c=='?') then
675          if (mixed) then
676            call add_error(stack, &
677              '? operator disallowed for Mixed elements')
678            goto 100
679          endif
680          current%repeater = REP_QUESTION_MARK
681          state = ST_END
682        elseif (verify(c, XML_WHITESPACE)==0) then
683          if (mixed) then
684            if (mixed_additional) then
685              call add_error(stack, &
686                'Missing "*" at end of Mixed element specification')
687              goto 100
688            endif
689          endif
690          state = ST_END
691        else
692          call add_error(stack, &
693            'Unexpected character "'//c//'" found after final ")"')
694          goto 100
695        endif
696
697      elseif (state==ST_END) then
698        !write(*,*)'ST_END'
699        if (verify(c, XML_WHITESPACE)==0) then
700          continue
701        else
702          call add_error(stack, &
703            'Unexpected token found after end of element specification')
704          goto 100
705        endif
706
707      endif
708
709    enddo
710
711    if (state/=ST_END) then
712      call add_error(stack, "Error in parsing contents of element declaration")
713      goto 100
714    endif
715
716    if (associated(element)) then
717      element%any = any
718      element%empty = empty
719      element%mixed = mixed
720      element%model => vs_str_alloc(trim(strip_spaces(contents)))
721      element%cp => top
722      element%internal = internal
723! For debugging it may be useful to dump the result here...
724! Also need to use the subroutine.
725!      call dumpCPtree(top)
726    else
727      if (associated(top)) call destroyCPtree(top)
728    endif
729    return
730
731100 if (associated(order)) deallocate(order)
732    if (associated(name)) deallocate(name)
733    if (associated(top)) call destroyCPtree(top)
734
735    contains
736      function strip_spaces(s1) result(s2)
737        character(len=*) :: s1
738        character(len=len(s1)) :: s2
739        integer :: i, i2
740        i2 = 1
741        do i = 1, len(s1)
742          if (verify(s1(i:i), XML_WHITESPACE)==0) cycle
743          s2(i2:i2) = s1(i:i)
744          i2 = i2 + 1
745        end do
746        s2(i2:) = ''
747      end function strip_spaces
748
749      function check_duplicates(cp) result(p)
750        type(content_particle_t), pointer :: cp
751        logical :: p
752
753        type(string_list) :: sl
754        type(content_particle_t), pointer :: tcp
755
756        if (cp%operator==OP_SEQ) then
757          p = .true.
758          return
759        endif
760
761        call init_string_list(sl)
762        tcp => cp%firstChild
763        p = .false.
764        do while (associated(tcp))
765          if (tcp%operator==OP_NAME) then
766            if (registered_string(sl, str_vs(tcp%name))) then
767              call destroy_string_list(sl)
768              if (cp%operator==OP_MIXED) then
769                call add_error(stack, &
770                  "Duplicate element names found in MIXED")
771              elseif (cp%operator==OP_CHOICE) then
772                call add_error(stack, &
773                  "Duplicate element names found in CHOICE")
774              endif
775              return
776            else
777              call add_string(sl, str_vs(tcp%name))
778            endif
779          endif
780          tcp => tcp%nextSibling
781        enddo
782        p = .true.
783        call destroy_string_list(sl)
784      end function check_duplicates
785  end subroutine parse_dtd_element
786
787
788  subroutine init_attribute_list(a_list)
789    type(attribute_list), intent(inout) :: a_list
790
791    allocate(a_list%list(0))
792  end subroutine init_attribute_list
793
794  subroutine destroy_attribute_t(a)
795    type(attribute_t), pointer :: a
796
797    if (associated(a%name)) deallocate(a%name)
798    if (associated(a%default)) deallocate(a%default)
799    call destroy_string_list(a%enumerations)
800
801    deallocate(a)
802  end subroutine destroy_attribute_t
803
804  subroutine destroy_attribute_list(a_list)
805    type(attribute_list), intent(inout) :: a_list
806
807    integer :: i
808
809    do i = 1, size(a_list%list)
810      deallocate(a_list%list(i)%name)
811      if (associated(a_list%list(i)%default)) deallocate(a_list%list(i)%default)
812      call destroy_string_list(a_list%list(i)%enumerations)
813    enddo
814    deallocate(a_list%list)
815
816  end subroutine destroy_attribute_list
817
818  function existing_attribute(a_list, name) result(p)
819    type(attribute_list), intent(inout) :: a_list
820    character(len=*), intent(in) :: name
821    logical :: p
822
823    integer :: i
824    p = .false.
825    do i = 1, size(a_list%list)
826      p = (str_vs(a_list%list(i)%name)==name)
827      if (p) exit
828    enddo
829  end function existing_attribute
830
831  function add_attribute(a_list, name, internal) result(a)
832    type(attribute_list), intent(inout) :: a_list
833    character(len=*), intent(in) :: name
834    logical, intent(in) :: internal
835    type(attribute_t), pointer :: a
836
837    integer :: i
838    type(attribute_t), pointer :: temp(:)
839
840    temp => a_list%list
841    allocate(a_list%list(size(temp)+1))
842    do i = 1, size(temp)
843      a_list%list(i)%name => temp(i)%name
844      a_list%list(i)%atttype = temp(i)%atttype
845      a_list%list(i)%attdefault = temp(i)%attdefault
846      a_list%list(i)%default => temp(i)%default
847      a_list%list(i)%enumerations%list => temp(i)%enumerations%list
848      a_list%list(i)%internal = temp(i)%internal
849    enddo
850    deallocate(temp)
851    a => a_list%list(i)
852
853    a%name => vs_str_alloc(name)
854    call init_string_list(a%enumerations)
855    a%internal = internal
856
857  end function add_attribute
858
859  function get_attribute(a_list, name) result(a)
860    type(attribute_list), intent(inout) :: a_list
861    character(len=*), intent(in) :: name
862    type(attribute_t), pointer :: a
863
864    integer :: i
865    do i = 1, size(a_list%list)
866      if (str_vs(a_list%list(i)%name)==name) then
867        a => a_list%list(i)
868        exit
869      endif
870    enddo
871  end function get_attribute
872
873  subroutine parse_dtd_attlist(contents, xv, namespaces, validCheck, stack, elem, internal)
874    character(len=*), intent(in) :: contents
875    integer, intent(in) :: xv
876    logical, intent(in) :: validCheck
877    logical, intent(in) :: namespaces
878    type(error_stack), intent(inout) :: stack
879    type(element_t), pointer :: elem
880    logical, intent(in) :: internal
881
882    integer :: i
883    integer :: state
884    character :: c, q
885    character, pointer :: name(:), attType(:), default(:), value(:), temp(:)
886
887    type(attribute_t), pointer :: ca
888    type(attribute_t), pointer :: ignore_att
889
890    ignore_att => null()
891    ! We need ignore_att to process but not take account of duplicate attributes
892    ! elem is optional so we can not record declarations if necessary.
893    ca => null()
894    name => null()
895    attType => null()
896    default => null()
897    value => null()
898    temp => null()
899
900    state = ST_START
901
902    do i = 1, len(contents) + 1
903      if (in_error(stack)) exit
904      if (i<=len(contents)) then
905        c = contents(i:i)
906      else
907        c = " "
908      endif
909
910      if (state==ST_START) then
911        !write(*,*)'ST_START'
912        if (verify(c, XML_WHITESPACE)==0) cycle
913        if (isInitialNameChar(c, xv)) then
914          name => vs_str_alloc(c)
915          state = ST_NAME
916        else
917          call add_error(stack, &
918            'Unexpected character in Attlist')
919        endif
920
921      elseif (state==ST_NAME) then
922        !write(*,*)'ST_NAME'
923        if (isNameChar(c, xv)) then
924          temp => vs_str_alloc(str_vs(name)//c)
925          deallocate(name)
926          name => temp
927        elseif (verify(c, XML_WHITESPACE)==0) then
928          if (namespaces.and..not.checkQName(str_vs(name), xv)) then
929            call add_error(stack, &
930              "Attribute name in ATTLIST must be QName")
931          elseif (associated(elem)) then
932            if (existing_attribute(elem%attlist, str_vs(name))) then
933              if (associated(ignore_att)) call destroy_attribute_t(ignore_att)
934              allocate(ignore_att)
935              call init_string_list(ignore_att%enumerations)
936              ignore_att%name => vs_vs_alloc(name)
937              ca => ignore_att
938            else
939              ca => add_attribute(elem%attlist, str_vs(name), internal)
940            endif
941          else
942            if (associated(ignore_att)) call destroy_attribute_t(ignore_att)
943            allocate(ignore_att)
944            call init_string_list(ignore_att%enumerations)
945            ignore_att%name => vs_vs_alloc(name)
946            ca => ignore_att
947          endif
948          deallocate(name)
949          state = ST_AFTERNAME
950        else
951          call add_error(stack, &
952            'Unexpected character in Attlist Name')
953        endif
954
955      elseif (state==ST_AFTERNAME) then
956        !write(*,*)'ST_AFTERNAME'
957        if (verify(c, XML_WHITESPACE)==0) cycle
958        if (verify(c, upperCase)==0) then
959          attType => vs_str_alloc(c)
960          state = ST_ATTTYPE
961        elseif (c=='(') then
962          allocate(value(0))
963          ca%attType = ATT_ENUM
964          state = ST_ENUMERATION
965        else
966          call add_error(stack, &
967            'Unexpected error after Attlist Name')
968        endif
969
970      elseif (state==ST_ATTTYPE) then
971        !write(*,*)'ST_ATTTYPE'
972        if (verify(c, upperCase)==0) then
973          temp => attType
974          attType => vs_str_alloc(str_vs(temp)//c)
975          deallocate(temp)
976        elseif (verify(c, XML_WHITESPACE)==0) then
977          ! xml:id constraint
978          if (str_vs(ca%name)=="xml:id" &
979            .and..not.str_vs(attType)=="ID") then
980            call add_error(stack, &
981              "xml:id attribute must be declared as type ID")
982          elseif (str_vs(attType)=='CDATA') then
983            ca%attType = ATT_CDATA
984            state = ST_AFTER_ATTTYPE
985          elseif (str_vs(attType)=='ID') then
986            if (validCheck) then
987              ! Validity Constraint: One ID per Element Type
988              if (associated(elem)) then
989                if (elem%id_declared) then
990                  call add_error(stack, &
991                    "Cannot have two declared attributes of type ID on one element type.")
992                else
993                  elem%id_declared = .true.
994                endif
995              endif
996            endif
997            ca%attType = ATT_ID
998            state = ST_AFTER_ATTTYPE
999          elseif (str_vs(attType)=='IDREF') then
1000            ca%attType = ATT_IDREF
1001            state = ST_AFTER_ATTTYPE
1002          elseif (str_vs(attType)=='IDREFS') then
1003            ca%attType = ATT_IDREFS
1004            state = ST_AFTER_ATTTYPE
1005          elseif (str_vs(attType)=='ENTITY') then
1006            ca%attType = ATT_ENTITY
1007            state = ST_AFTER_ATTTYPE
1008          elseif (str_vs(attType)=='ENTITIES') then
1009            ca%attType = ATT_ENTITIES
1010            state = ST_AFTER_ATTTYPE
1011          elseif (str_vs(attType)=='NMTOKEN') then
1012            ca%attType = ATT_NMTOKEN
1013            state = ST_AFTER_ATTTYPE
1014          elseif (str_vs(attType)=='NMTOKENS') then
1015            ca%attType = ATT_NMTOKENS
1016            state = ST_AFTER_ATTTYPE
1017          elseif (str_vs(attType)=='NOTATION') then
1018            ca%attType = ATT_NOTATION
1019            state = ST_AFTER_NOTATION
1020          else
1021            call add_error(stack, &
1022              'Unknown AttType')
1023          endif
1024          deallocate(attType)
1025        else
1026          call add_error(stack, &
1027            'Unexpected character in AttType')
1028        endif
1029
1030      elseif (state==ST_AFTER_NOTATION) then
1031        !write(*,*)'ST_AFTER_NOTATION'
1032        if (verify(c, XML_WHITESPACE)==0) cycle
1033        if (c=='(') then
1034          state = ST_NOTATION_LIST
1035        else
1036          call add_error(stack, &
1037            'Unexpected character after Notation')
1038        endif
1039
1040      elseif (state==ST_NOTATION_LIST) then
1041        !write(*,*)'ST_NOTATION_LIST'
1042        if (verify(c, XML_WHITESPACE)==0) cycle
1043        if (isInitialNameChar(c, xv)) then
1044          value => vs_str_alloc(c)
1045          state = ST_ENUM_NAME
1046        else
1047          call add_error(stack, &
1048            'Unexpected character in Notation list')
1049        endif
1050
1051      elseif (state==ST_ENUMERATION) then
1052        !write(*,*)'ST_ENUMERATION'
1053        if (verify(c, XML_WHITESPACE)==0) cycle
1054        if (isNameChar(c, xv)) then
1055          temp => vs_str_alloc(str_vs(value)//c)
1056          deallocate(value)
1057          value => temp
1058          state = ST_ENUM_NAME
1059        elseif (c=='|') then
1060          call add_error(stack, &
1061            "Missing token in Enumeration")
1062        elseif (c==')') then
1063          call add_error(stack, &
1064            "Missing tokens in Enumeration")
1065        else
1066          call add_error(stack, &
1067            'Unexpected character in attlist enumeration')
1068        endif
1069
1070      elseif (state==ST_ENUM_NAME) then
1071        !write(*,*)'ST_ENUM_NAME'
1072        if (isNameChar(c, xv)) then
1073          temp => vs_str_alloc(str_vs(value)//c)
1074          deallocate(value)
1075          value => temp
1076        elseif (verify(c, XML_WHITESPACE)==0) then
1077          if (validCheck.and.registered_string(ca%enumerations, str_vs(value))) then
1078            call add_error(stack, &
1079              "Duplicate enumeration value in ATTLIST")
1080          elseif (namespaces.and.ca%attType==ATT_NOTATION &
1081            .and..not.checkNCName(str_vs(value), xv)) then
1082            call add_error(stack, &
1083              "Notation name must be NCName")
1084          else
1085            call add_string(ca%enumerations, str_vs(value))
1086          endif
1087          deallocate(value)
1088          state = ST_SEPARATOR
1089        elseif (c=='|') then
1090          if (validCheck.and.registered_string(ca%enumerations, str_vs(value))) then
1091            call add_error(stack, &
1092              "Duplicate enumeration value in ATTLIST")
1093          elseif (namespaces.and.ca%attType==ATT_NOTATION &
1094            .and..not.checkNCName(str_vs(value), xv)) then
1095            call add_error(stack, &
1096              "Notation name must be NCName")
1097          else
1098            call add_string(ca%enumerations, str_vs(value))
1099          endif
1100          deallocate(value)
1101          if (ca%attType==ATT_NOTATION) then
1102            state = ST_NOTATION_LIST
1103          else
1104            allocate(value(0))
1105            state = ST_ENUMERATION
1106          endif
1107        elseif (c==')') then
1108          if (size(value)==0) then
1109            call add_error(stack, &
1110              'Missing token in Enumeration list')
1111          endif
1112          if (validCheck.and.registered_string(ca%enumerations, str_vs(value))) then
1113            call add_error(stack, &
1114              "Duplicate enumeration value in ATTLIST")
1115          elseif (namespaces.and.ca%attType==ATT_NOTATION &
1116            .and..not.checkNCName(str_vs(value), xv)) then
1117            call add_error(stack, &
1118              "Notation name must be NCName")
1119          else
1120            call add_string(ca%enumerations, str_vs(value))
1121          endif
1122          deallocate(value)
1123          state = ST_AFTER_ATTTYPE_SPACE
1124        else
1125          call add_error(stack, &
1126            'Unexpected character in attlist enumeration')
1127        endif
1128
1129      elseif (state==ST_SEPARATOR) then
1130        !write(*,*)'ST_SEPARATOR'
1131        if (verify(c, XML_WHITESPACE)==0) cycle
1132        if (c=='|') then
1133          if (ca%attType==ATT_NOTATION) then
1134            state = ST_NOTATION_LIST
1135          else
1136            allocate(value(0))
1137            state = ST_ENUMERATION
1138          endif
1139        elseif (c==')') then
1140          state = ST_AFTER_ATTTYPE_SPACE
1141        else
1142          call add_error(stack, &
1143            'Unexpected character in attlist enumeration')
1144        endif
1145
1146      elseif (state==ST_AFTER_ATTTYPE_SPACE) then
1147        if (verify(c, XML_WHITESPACE)/=0) then
1148          call add_error(stack, &
1149            'Missing whitespace in attlist enumeration')
1150        endif
1151        state = ST_AFTER_ATTTYPE
1152
1153      elseif (state==ST_AFTER_ATTTYPE) then
1154        !write(*,*)'ST_AFTER_ATTTYPE'
1155        if (verify(c, XML_WHITESPACE)==0) cycle
1156        if (c=='#') then
1157          allocate(default(0))
1158          state = ST_DEFAULT_DECL
1159        elseif (c=='"'.or.c=="'") then
1160          if (validCheck) then
1161            ! Validity Constraint: ID Attribute Default
1162            if (ca%attType==ATT_ID) &
1163              call add_error(stack, &
1164              "Attribute of type ID may not have default value")
1165          endif
1166          ca%attDefault = ATT_DEFAULT
1167          q = c
1168          allocate(value(0))
1169          state = ST_DEFAULTVALUE
1170        else
1171          call add_error(stack, &
1172            'Unexpected character after AttType')
1173        endif
1174
1175      elseif (state==ST_DEFAULT_DECL) then
1176        !write(*,*)'ST_DEFAULT_DECL'
1177        if (verify(c, upperCase)==0) then
1178          temp => vs_str_alloc(str_vs(default)//c)
1179          deallocate(default)
1180          default => temp
1181        elseif (verify(c, XML_WHITESPACE)==0) then
1182          if (str_vs(default)=='REQUIRED') then
1183            ca%attdefault = ATT_REQUIRED
1184            deallocate(default)
1185            state = ST_START
1186          elseif (str_vs(default)=='IMPLIED') then
1187            ca%attdefault = ATT_IMPLIED
1188            deallocate(default)
1189            state = ST_START
1190          elseif (str_vs(default)=='FIXED') then
1191            if (validCheck) then
1192              ! Validity Constraint: ID Attribute Default
1193              if (ca%attType==ATT_ID) &
1194                call add_error(stack, &
1195                "Attribute of type ID may not have FIXED value")
1196            endif
1197            ca%attdefault = ATT_FIXED
1198            deallocate(default)
1199            state = ST_AFTERDEFAULTDECL
1200          else
1201            call add_error(stack, &
1202              'Unknown Default declaration')
1203          endif
1204        else
1205          call add_error(stack, &
1206            'Unexpected character in Default declaration')
1207        endif
1208
1209      elseif (state==ST_AFTERDEFAULTDECL) then
1210        !write(*,*)'ST_AFTERDEFAULTDECL'
1211        if (verify(c, XML_WHITESPACE)==0) cycle
1212        if (c=='"') then
1213          q = c
1214          allocate(value(0))
1215          state = ST_DEFAULTVALUE
1216        elseif (c=="'") then
1217          q = c
1218          allocate(value(0))
1219          state = ST_DEFAULTVALUE
1220        else
1221          call add_error(stack, &
1222            'Unexpected character after Default declaration')
1223        endif
1224
1225      elseif (state==ST_DEFAULTVALUE) then
1226        !write(*,*)'ST_DEFAULTVALUE'
1227        if (c==q) then
1228          if (ca%attType/=ATT_CDATA) then
1229            temp => vs_str_alloc(att_value_normalize(str_vs(value)))
1230            deallocate(value)
1231            value => temp
1232          endif
1233          if (validCheck) then
1234            select case(ca%attType)
1235              ! Can't have ID with defaults
1236            case (ATT_IDREF)
1237              ! VC: IDREF
1238              if (namespaces) then
1239                if (.not.checkNCName(str_vs(value), xv)) &
1240                  call add_error(stack, &
1241                  "Attributes of type IDREF must have a value which is an XML NCName")
1242              else
1243                if (.not.checkName(str_vs(value), xv)) &
1244                  call add_error(stack, &
1245                  "Attributes of type IDREF must have a value which is an XML Name")
1246              endif
1247            case (ATT_IDREFS)
1248              ! VC: IDREF
1249              if (namespaces) then
1250                if (.not.checkNCNames(str_vs(value), xv)) &
1251                  call add_error(stack, &
1252                  "Attributes of type IDREFS must have a value which contains only XML NCNames")
1253              else
1254                if (.not.checkNames(str_vs(value), xv)) &
1255                  call add_error(stack, &
1256                  "Attributes of type IDREFS must have a value which contains only XML Names")
1257              endif
1258            case (ATT_ENTITY)
1259              ! VC: Entity Name
1260              if (namespaces) then
1261                if (.not.checkNCName(str_vs(value), xv)) &
1262                  call add_error(stack, &
1263                  "Attributes of type ENTITY must have a value which is an XML NCName")
1264              else
1265                if (.not.checkName(str_vs(value), xv)) &
1266                  call add_error(stack, &
1267                  "Attributes of type ENTITY must have a value which is an XML Name")
1268              endif
1269            case (ATT_ENTITIES)
1270              ! VC: Entity Name
1271              if (namespaces) then
1272                if (.not.checkNames(str_vs(value), xv)) &
1273                  call add_error(stack, &
1274                  "Attributes of type ENTITIES must have a value which contains only XML NCNames")
1275              else
1276                if (.not.checkNames(str_vs(value), xv)) &
1277                  call add_error(stack, &
1278                  "Attributes of type ENTITIES must have a value which contains only XML Names")
1279              endif
1280            case (ATT_NMTOKEN)
1281              ! VC Name Token
1282              if (.not.checkNmtoken(str_vs(value), xv)) &
1283                call add_error(stack, &
1284                "Attributes of type NMTOKEN must have a value which is a NMTOKEN")
1285            case (ATT_NMTOKENS)
1286              ! VC: Name Token
1287              if (.not.checkNmtokens(str_vs(value), xv)) &
1288                call add_error(stack, &
1289                "Attributes of type NMTOKENS must have a value which contain only NMTOKENs")
1290            case (ATT_NOTATION)
1291              ! VC: Notation Attributes
1292              if (namespaces) then
1293                if (.not.checkNCName(str_vs(value), xv)) &
1294                  call add_error(stack, &
1295                  "Attributes of type NOTATION must have a value which is an XMLNCName")
1296              else
1297                if (.not.checkName(str_vs(value), xv)) &
1298                  call add_error(stack, &
1299                  "Attributes of type NOTATION must have a value which is an XML Name")
1300              endif
1301            case (ATT_ENUM)
1302              ! VC: Enumeration
1303              if (.not.checkNmtoken(str_vs(value), xv)) &
1304                call add_error(stack, &
1305                "Attributes of type ENUM must have a value which is an NMTOKENs")
1306              if (.not.registered_string(ca%enumerations, str_vs(value))) &
1307                call add_error(stack, &
1308                "Default value of ENUM does not match permitted values")
1309            end select
1310          endif
1311          if (.not.in_error(stack)) then
1312            if (ca%attType==ATT_ENTITIES) then
1313              call destroy_string_list(ca%enumerations)
1314              ca%enumerations = tokenize_to_string_list(str_vs(value))
1315            endif
1316            ca%default => value
1317            value => null()
1318            state = ST_START
1319          endif
1320        else
1321          temp => vs_str_alloc(str_vs(value)//c)
1322          deallocate(value)
1323          value => temp
1324        endif
1325
1326      endif
1327
1328    enddo
1329
1330    if (associated(ignore_att)) call destroy_attribute_t(ignore_att)
1331
1332    if (.not.in_error(stack)) then
1333      if (state==ST_START) then
1334        return
1335      else
1336        call add_error(stack, &
1337          'Incomplete Attlist declaration')
1338      endif
1339    endif
1340
1341    if (associated(name)) deallocate(name)
1342    if (associated(attType)) deallocate(attType)
1343    if (associated(default)) deallocate(default)
1344    if (associated(value)) deallocate(value)
1345
1346  end subroutine parse_dtd_attlist
1347
1348  subroutine report_declarations(elem, attributeDecl_handler)
1349    type(element_t), intent(in) :: elem
1350    interface
1351      subroutine attributeDecl_handler(eName, aName, type, mode, value)
1352        character(len=*), intent(in) :: eName
1353        character(len=*), intent(in) :: aName
1354        character(len=*), intent(in) :: type
1355        character(len=*), intent(in), optional :: mode
1356        character(len=*), intent(in), optional :: value
1357      end subroutine attributeDecl_handler
1358    end interface
1359
1360    integer :: i
1361    character(len=8) :: type
1362    character(len=8) :: mode
1363    type(attribute_t), pointer :: a
1364
1365    do i = 1, size(elem%attlist%list)
1366      a => elem%attlist%list(i)
1367      type = ATT_TYPES(a%attType)
1368      select case (a%attDefault)
1369      case (ATT_REQUIRED)
1370        mode = "REQUIRED"
1371      case (ATT_IMPLIED)
1372        mode = "IMPLIED"
1373      case (ATT_FIXED)
1374        mode = "FIXED"
1375      end select
1376
1377      if (a%attType==ATT_NOTATION) then
1378        if (a%attDefault==ATT_DEFAULT) then
1379          if (associated(a%default)) then
1380            call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), &
1381              'NOTATION '//make_token_group(a%enumerations), value=str_vs(a%default))
1382          else
1383            call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), &
1384              'NOTATION '//make_token_group(a%enumerations))
1385          endif
1386        else
1387          if (associated(a%default)) then
1388            call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), &
1389              'NOTATION '//make_token_group(a%enumerations), mode=trim(mode), &
1390              value=str_vs(a%default))
1391          else
1392            call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), &
1393              'NOTATION '//make_token_group(a%enumerations), mode=trim(mode))
1394          endif
1395        endif
1396      elseif (a%attType==ATT_ENUM) then
1397        if (a%attDefault==ATT_DEFAULT) then
1398          if (associated(a%default)) then
1399            call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), &
1400              make_token_group(a%enumerations), value=str_vs(a%default))
1401          else
1402            call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), &
1403              make_token_group(a%enumerations))
1404          endif
1405        else
1406          if (associated(a%default)) then
1407            call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), &
1408              make_token_group(a%enumerations), mode=trim(mode), &
1409              value=str_vs(a%default))
1410          else
1411            call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), &
1412              make_token_group(a%enumerations), mode=trim(mode))
1413          endif
1414        endif
1415      else
1416        if (a%attDefault==ATT_DEFAULT) then
1417          if (associated(a%default)) then
1418            call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), &
1419              trim(type), value=str_vs(a%default))
1420          else
1421            call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), &
1422              trim(type))
1423          endif
1424        else
1425          if (associated(a%default)) then
1426            call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), &
1427              trim(type), mode=trim(mode), value=str_vs(a%default))
1428          else
1429            call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), &
1430              trim(type), mode=trim(mode))
1431          endif
1432        endif
1433      endif
1434    enddo
1435
1436
1437  end subroutine report_declarations
1438
1439  pure function make_token_group_len(s_list) result(n)
1440    type(string_list), intent(in) :: s_list
1441    integer :: n
1442
1443    integer :: i
1444    n = size(s_list%list) + 1
1445    do i = 1, size(s_list%list)
1446      n = n + size(s_list%list(i)%s)
1447    enddo
1448  end function make_token_group_len
1449
1450  function make_token_group(s_list) result(s)
1451    type(string_list), intent(in) :: s_list
1452    character(len=make_token_group_len(s_list)) :: s
1453
1454    integer :: i, m, n
1455    s(1:1) = '('
1456    n = 2
1457    do i = 1, size(s_list%list)-1
1458      m = size(s_list%list(i)%s)
1459      s(n:n+m) = str_vs(s_list%list(i)%s)//'|'
1460      n = n + m + 1
1461    enddo
1462    s(n:) = str_vs(s_list%list(i)%s)//')'
1463  end function make_token_group
1464
1465  function attribute_has_default(att) result(p)
1466    type(attribute_t), pointer :: att
1467    logical :: p
1468
1469    if (associated(att)) then
1470      p = att%attDefault==ATT_DEFAULT.or.att%attDefault==ATT_FIXED
1471    else
1472      p = .false.
1473    endif
1474  end function attribute_has_default
1475
1476  function get_attlist_size(elem) result(n)
1477    type(element_t), pointer :: elem
1478    integer :: n
1479
1480    if (associated(elem)) then
1481      n = size(elem%attlist%list)
1482    else
1483      n = 0
1484    endif
1485  end function get_attlist_size
1486
1487  function get_attdecl_by_index(elem, n) result(att)
1488    type(element_t), pointer :: elem
1489    integer, intent(in) :: n
1490    type(attribute_t), pointer :: att
1491
1492    att => null()
1493    if (associated(elem)) then
1494      if (n>0.and.n<=size(elem%attlist%list)) then
1495        att => elem%attlist%list(n)
1496      endif
1497    endif
1498  end function get_attdecl_by_index
1499
1500  function get_attdecl_by_name(elem, name) result(att)
1501    type(element_t), pointer :: elem
1502    character(len=*), intent(in) :: name
1503    type(attribute_t), pointer :: att
1504
1505    integer :: i
1506    att => null()
1507    if (associated(elem)) then
1508      do i = 1, size(elem%attlist%list)
1509        if (str_vs(elem%attlist%list(i)%name)==name) then
1510          att => elem%attlist%list(i)
1511          return
1512        endif
1513      enddo
1514    endif
1515  end function get_attdecl_by_name
1516
1517  pure function express_att_decl_len(a) result(n)
1518    type(attribute_t), intent(in) :: a
1519    integer :: n
1520
1521    if (a%attType==ATT_ENUM) then
1522      n = size(a%name)
1523    else
1524      n = size(a%name)+1+len_trim(ATT_TYPES(a%attType))
1525    endif
1526
1527    if (a%attType==ATT_NOTATION &
1528      .or.a%attType==ATT_ENUM) &
1529      n = n + 1 + make_token_group_len(a%enumerations)
1530
1531    select case(a%attDefault)
1532    case (ATT_REQUIRED)
1533      n = n + len(" #REQUIRED")
1534    case (ATT_IMPLIED)
1535      n = n + len(" #IMPLIED")
1536    case (ATT_DEFAULT)
1537      n = n + len(" ")
1538    case (ATT_FIXED)
1539      n = n + len(" #FIXED")
1540    end select
1541
1542    if (associated(a%default)) &
1543      n = n + 3 + size(a%default)
1544  end function express_att_decl_len
1545
1546  function express_attribute_declaration(a) result(s)
1547    type(attribute_t), intent(in) :: a
1548    character(len=express_att_decl_len(a)) :: s
1549
1550    if (a%attType==ATT_ENUM) then
1551      s = str_vs(a%name)
1552    else
1553      s = str_vs(a%name)//" "//ATT_TYPES(a%attType)
1554    endif
1555    if (a%attType==ATT_NOTATION &
1556      .or.a%attType==ATT_ENUM) &
1557      s = trim(s)//" "//make_token_group(a%enumerations)
1558
1559    select case(a%attDefault)
1560    case (ATT_REQUIRED)
1561      s = trim(s)//" #REQUIRED"
1562    case (ATT_IMPLIED)
1563      s = trim(s)//" #IMPLIED"
1564    case (ATT_DEFAULT)
1565      s = trim(s)//" "
1566    case (ATT_FIXED)
1567      s = trim(s)//" #FIXED"
1568    end select
1569
1570    if (associated(a%default)) &
1571      s = trim(s)//" """//str_vs(a%default)//""""
1572  end function express_attribute_declaration
1573
1574  function get_att_type_enum(s) result(n)
1575    character(len=*), intent(in) :: s
1576    integer :: n
1577
1578    select case(s)
1579    case ('CDATA')
1580      n = ATT_CDATA
1581    case ('ID')
1582      n = ATT_ID
1583    case ('IDREF')
1584      n = ATT_IDREF
1585    case ('IDREFS')
1586      n = ATT_IDREFS
1587    case ('NMTOKEN')
1588      n = ATT_NMTOKEN
1589    case ('NMTOKENS')
1590      n = ATT_NMTOKENS
1591    case ('ENTITY')
1592      n = ATT_ENTITY
1593    case ('ENTITIES')
1594      n = ATT_ENTITIES
1595    case ('NOTATION')
1596      n = ATT_NOTATION
1597    case ('CDANO')
1598      n= ATT_CDANO
1599    case ('CDAMB')
1600      n = ATT_CDAMB
1601    end select
1602  end function get_att_type_enum
1603
1604  pure function att_value_normalize_len(s1) result(n)
1605    character(len=*), intent(in) :: s1
1606    integer :: n
1607
1608    integer :: i
1609    logical :: w
1610
1611    n = 0
1612    w = .true.
1613    do i = 1, len(s1)
1614      if (w.and.(verify(s1(i:i),XML_WHITESPACE)==0)) cycle
1615      w = .false.
1616      n = n + 1
1617      if (verify(s1(i:i),XML_WHITESPACE)==0) w = .true.
1618    enddo
1619    if (w) n = n - 1 ! Discard final space
1620
1621  end function att_value_normalize_len
1622
1623  function att_value_normalize(s1) result(s2)
1624    character(len=*), intent(in) :: s1
1625    character(len=att_value_normalize_len(s1)) :: s2
1626
1627    integer :: i, i2
1628    logical :: w
1629
1630    i = 0
1631    i2 = 1
1632    w = .true.
1633    do while (i2<=len(s2))
1634      i = i + 1
1635      if (w.and.(verify(s1(i:i),XML_WHITESPACE)==0)) cycle
1636      w = .false.
1637      s2(i2:i2) = s1(i:i)
1638      i2 = i2 + 1
1639      if (verify(s1(i:i),XML_WHITESPACE)==0) w = .true.
1640    enddo
1641
1642  end function att_value_normalize
1643
1644#endif
1645end module m_common_element
1646