« back to all changes in this revision
Viewing changes to Src/FoX/common/m_common_element.F90
- browse files at revision 578
- compare with another revision
- download diff
- download tarball
- view history from revision 578
- Committer: Alberto Garcia
- Date: 2016-10-24 13:50:32 UTC
- mfrom: (560.1.36 4.1)
- Revision ID: albertog@icmab.es-20161024135032-yf1fynnn1v3j55vo
Merge 4.1 (595, 596)
- Enabled default chemical potentials if they are named equally
- Implement CML calls using an upgraded Src/wxml library
(Remove FoX)
- Enabled default chemical potentials if they are named equally
- Implement CML calls using an upgraded Src/wxml library
(Remove FoX)
- files added:
- Docs/branch-changes/NOTES.cml
- files removed:
- Src/FoX
- Src/FoX/common
- Src/FoX/config
- Src/FoX/fsys
- Src/FoX/utils
- Src/FoX/wcml
- Src/FoX/wxml
- files modified:
- Docs/siesta.tex
added
removed
Src/FoX/common/m_common_element.F90
1
module 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
169
contains
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
731
100 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
1645
end module m_common_element
Loggerhead is a web-based interface for Breezy
Version: 2.0.1