summaryrefslogtreecommitdiffstats
path: root/tcllib/modules/pt/pt_peg_to_param.tcl
blob: 0ed0179aac53127bdcc94546cd595961d534b930 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
# peg_to_param.tcl --
#
#	Conversion of PEG to PARAM assembler.
#
# Copyright (c) 2009-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: pt_peg_to_param.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $

# This package takes the canonical serialization of a parsing
# expression grammar and produces text in PARAM assembler, i.e.
# readable machine code for the PARAM virtual machine.

## NOTE: Should have cheat sheet of PARAM instructions (which parts of
## the arch state they touch, and secondly, bigger effects).

# ### ### ### ######### ######### #########
## Requisites

package  require Tcl 8.5
package  require pt::peg             ; # Verification that the input
				       # is proper.
package  require pt::pe              ; # Walking an expression.
package  require text::write         ; # Text generation support
package  require char

# ### ### ### ######### ######### #########
##

namespace eval ::pt::peg::to::param {
    namespace export \
	reset configure convert

    namespace ensemble create
}

# ### ### ### ######### ######### #########
## API.

proc ::pt::peg::to::param::reset {} {
    variable template @code@
    variable name     a_pe_grammar
    variable file     unknown
    variable user     unknown
    variable inline   1
    variable compact  1
    return
}

proc ::pt::peg::to::param::configure {args} {
    variable template
    variable name
    variable file
    variable user
    variable inline
    variable compact

    if {[llength $args] == 0} {
	return [list \
		    -inline   $inline \
		    -compact  $compact \
		    -file     $file \
		    -name     $name \
		    -template $template \
		    -user     $user]
    } elseif {[llength $args] == 1} {
	lassign $args option
	set variable [string range $option 1 end]
	if {[info exists $variable]} {
	    return [set $variable]
	} else {
	    return -code error "Expected one of -compact, -file, -inline, -name, -template, or -user, got \"$option\""
	}
    } elseif {[llength $args] % 2 == 0} {
	foreach {option value} $args {
	    set variable [string range $option 1 end]
	    if {![info exists $variable]} {
		return -code error "Expected one of -compact, -file, -inline, -name, -template, or -user, got \"$option\""
	    }
	}
	foreach {option value} $args {
	    set variable [string range $option 1 end]
	    switch -exact -- $variable {
		template {
		    if {$value eq {}} {
			return -code error "Expected template, got the empty string"
		    }
		}
		inline - compact {
		    if {![::string is boolean -strict $value]} {
			return -code error "Expected boolean, got \"$value\""
		    }
		}
		name -
		file -
		user { }
	    }
	    set $variable $value
	}
    } else {
	return -code error {wrong#args, expected option value ...}
    }
}

proc ::pt::peg::to::param::convert {serial} {
    variable template
    variable name
    variable file
    variable user

    Op::Asm::Setup

    ::pt::peg verify-as-canonical $serial

    # Unpack the serialization, known as canonical
    array set peg $serial
    array set peg $peg(pt::grammar::peg)
    unset     peg(pt::grammar::peg)

    set modes {}
    foreach {symbol def} $peg(rules) {
	lassign $def _ is _ mode
	lappend modes $symbol $mode
    }

    text::write reset
    set blocks {}

    # Translate all expressions/symbols, results are stored in
    # text::write blocks, command results are the block ids.
    lappend blocks [set start [Expression $peg(start) $modes]]

    foreach {symbol def} $peg(rules) {
	lassign $def _ is _ mode
	lappend blocks [Symbol $symbol $mode $is $modes]
    }

    # Assemble the output from the stored blocks.
    text::write clear
    Op::Asm::Header {Grammar Start Expression}
    Op::Asm::Label <<MAIN>>
    Op::Asm::Call $start 0
    Op::Asm::Ins  halt
    text::write /line

    Op::Asm::Use {*}$blocks

    # At last retrieve the fully assembled result and integrate with
    # the chosen template.

    return [string map \
		[list \
		     @user@   $user \
		     @format@ PEG   \
		     @file@   $file \
		     @name@   $name \
		     @code@   [text::write get]] $template]

    # ### ### ### ######### ######### #########
}

# ### ### ### ######### ######### #########
## Internals

proc ::pt::peg::to::param::Expression {expression modes} {
    return [pt::pe bottomup \
		[list [namespace current]::Op $modes] \
		$expression]
}

proc ::pt::peg::to::param::Symbol {symbol mode rhs modes} {

    set expression [Expression $rhs $modes]

    text::write clear
    Op::Asm::Header "$mode Symbol '$symbol'"
    text::write store FUN_HEADER

    Op::Asm::Start
    Op::Asm::ReExpression $symbol
    Op::Asm::GenAST $expression
    Op::Asm::PE $rhs

    set gen [dict get $result gen]

    Op::Asm::Function sym_$symbol {

	# We have six possibilites for the combination of AST node
	# generation by the rhs and AST generation by the symbol. Two
	# of these (leaf/0, value/0 coincide, leaving 5). This
	# controls the use of AS/ARS instructions.

	switch -exact -- $mode/$gen {
	    value/1 {
		# Generate value for symbol, rhs may have generated
		# AST nodes as well, keep rhs

		set found [Op::Asm::NewLabel found]

		Op::Asm::Ins symbol_restore $symbol
		Op::Asm::Ins found! jump $found

		Op::Asm::Ins loc_push
		Op::Asm::Ins ast_push

		Op::Asm::Call $expression

		Op::Asm::Ins fail! value_clear
		Op::Asm::Ins ok!   value_reduce $symbol

		Op::Asm::Ins symbol_save       $symbol
		Op::Asm::Ins error_nonterminal $symbol

		Op::Asm::Ins ast_pop_rewind
		Op::Asm::Ins loc_pop_discard

		Op::Asm::Label $found
		Op::Asm::Ins ok! ast_value_push
	    }
	    leaf/0 -
	    value/0 {
		# Generate value for symbol, rhs cannot generate its
		# own AST nodes => leaf/0.

		set found [Op::Asm::NewLabel found]

		Op::Asm::Ins symbol_restore $symbol
		Op::Asm::Ins found! jump $found

		Op::Asm::Ins loc_push

		Op::Asm::Call $expression

		Op::Asm::Ins fail! value_clear
		Op::Asm::Ins ok!   value_leaf $symbol

		Op::Asm::Ins symbol_save       $symbol
		Op::Asm::Ins error_nonterminal $symbol

		Op::Asm::Ins loc_pop_discard

		Op::Asm::Label $found
		Op::Asm::Ins ok! ast_value_push
	    }
	    leaf/1 {
		# Generate value for symbol, rhs may have generated
		# AST nodes as well, discard rhs.

		set found [Op::Asm::NewLabel found]

		Op::Asm::Ins symbol_restore $symbol
		Op::Asm::Ins found! jump $found

		Op::Asm::Ins loc_push
		Op::Asm::Ins ast_push

		Op::Asm::Call $expression

		Op::Asm::Ins fail! value_clear
		Op::Asm::Ins ok!   value_leaf   $symbol

		Op::Asm::Ins symbol_save       $symbol
		Op::Asm::Ins error_nonterminal $symbol

		Op::Asm::Ins ast_pop_rewind
		Op::Asm::Ins loc_pop_discard

		Op::Asm::Label $found
		Op::Asm::Ins ok! ast_value_push
	    }
	    void/1 {
		# Generate no value for symbol, rhs may have generated
		# AST nodes as well, discard rhs.

		Op::Asm::Ins symbol_restore $symbol ; # Implied
		Op::Asm::Ins found! return

		Op::Asm::Ins loc_push
		Op::Asm::Ins ast_push

		Op::Asm::Call $expression

		Op::Asm::Ins value_clear

		Op::Asm::Ins symbol_save       $symbol
		Op::Asm::Ins error_nonterminal $symbol

		Op::Asm::Ins ast_pop_rewind
		Op::Asm::Ins loc_pop_discard
	    }
	    void/0 {
		# Generate no value for symbol, rhs cannot generate
		# its own AST nodes. Nothing to save nor discard.

		Op::Asm::Ins symbol_restore $symbol ; # Implied
		Op::Asm::Ins found! return

		Op::Asm::Ins loc_push

		Op::Asm::Call $expression

		Op::Asm::Ins value_clear

		Op::Asm::Ins symbol_save       $symbol
		Op::Asm::Ins error_nonterminal $symbol

		Op::Asm::Ins loc_pop_discard
	    }
	}
    } $expression
    Op::Asm::Done
}

namespace eval ::pt::peg::to::param::Op {
    namespace export \
	alpha alnum ascii digit graph lower print \
	punct space upper wordchar xdigit ddigit \
	dot epsilon t .. n ? * + & ! x / 
}

proc ::pt::peg::to::param::Op {modes pe op arguments} {
    return [namespace eval Op [list $op $modes {*}$arguments]]
}

proc ::pt::peg::to::param::Op::epsilon {modes} {
    Asm::Start
    Asm::ReExpression epsilon
    Asm::Direct {
	Asm::Ins status_ok
    }
    Asm::Done
}

proc ::pt::peg::to::param::Op::dot {modes} {
    Asm::Start
    Asm::ReExpression dot
    Asm::Direct {
	Asm::Ins input_next \"dot\"
    }
    Asm::Done
}

foreach test {
    alpha alnum ascii digit graph lower print
    punct space upper wordchar xdigit ddigit
} {
    proc ::pt::peg::to::param::Op::$test {modes} \
	[string map [list @ $test] {
	    variable ::pt::peg::to::param::inline
	    Asm::Start
	    Asm::ReExpression @
	    if {$inline} {
		Asm::Direct {
		    Asm::Ins input_next \"@\"
		    Asm::Ins ok! test_@
		}
	    } else {
		Asm::Function [Asm::NewBlock @] {
		    Asm::Ins input_next \"@\"
		    Asm::Ins ok! test_@
		}
	    }
	    Asm::Done
	}]
}

proc ::pt::peg::to::param::Op::t {modes char} {
    variable ::pt::peg::to::param::inline
    Asm::Start
    Asm::ReTerminal t $char
    if {$inline} {
	Asm::Direct {
	    set c [char quote string $char]

	    Asm::Ins input_next "\"t $c\""
	    Asm::Ins ok! test_char \"$c\"
	}
    } else {
	Asm::Function [Asm::NewBlock char ] {
	    set c [char quote string $char]

	    Asm::Ins input_next "\"t $c\""
	    Asm::Ins ok! test_char \"$c\"
	}
    }
    Asm::Done
}

proc ::pt::peg::to::param::Op::.. {modes chstart chend} {
    variable ::pt::peg::to::param::inline
    Asm::Start
    Asm::ReTerminal .. $chstart $chend
    if {$inline} {
	Asm::Direct {
	    set s [char quote string $chstart]
	    set e [char quote string $chend]

	    Asm::Ins input_next "\".. $s $e\""
	    Asm::Ins ok! test_range \"$s\" \"$e\"
	}
    } else {
	Asm::Function [Asm::NewBlock range] {
	    set s [char quote string $chstart]
	    set e [char quote string $chend]

	    Asm::Ins input_next "\".. $s $e\""
	    Asm::Ins ok! test_range \"$s\" \"$e\"
	}
    }
    Asm::Done
}

proc ::pt::peg::to::param::Op::n {modes symbol} {
    # symbol mode determines AST generation
    # void       => non-generative,
    # leaf/value => generative.

    Asm::Start
    Asm::ReTerminal n $symbol

    if {![dict exists $modes $symbol]} {
	# Incomplete grammar. The symbol has no definition.
	Asm::Direct {
	    Asm::Ins status_fail {} "; # Undefined symbol '$symbol'"
	}
    } else {
	Asm::GenAST [list gen [expr { [dict get $modes $symbol] ne "void" }]]
	Asm::Direct {
	    Asm::Ins call sym_$symbol
	}
    }
    Asm::Done
}

proc ::pt::peg::to::param::Op::& {modes expression} {
    # Note: This operation could be inlined, as it has no special
    #       control flow. Not done to make the higher-level ops are
    #       similar in construction and use = consistent and simple.

    Asm::Start
    Asm::ReExpression & $expression
    Asm::GenAST $expression

    Asm::Function [Asm::NewBlock ahead] {
	Asm::Ins loc_push
	Asm::Call $expression
	Asm::Ins loc_pop_rewind
    } $expression
    Asm::Done
}

proc ::pt::peg::to::param::Op::! {modes expression} {
    # Note: This operation could be inlined, as it has no special
    #       control flow. Not done to make the higher-level ops are
    #       similar in construction and use = consistent and simple.

    Asm::Start
    Asm::ReExpression ! $expression
    if {[dict get $expression gen]} {
	Asm::Function [Asm::NewBlock notahead] {
	    # The sub-expression may generate AST elements. We must
	    # not pass them through.

	    Asm::Ins loc_push
	    Asm::Ins ast_push

	    Asm::Call $expression

	    Asm::Ins fail! ast_pop_discard
	    Asm::Ins ok!   ast_pop_rewind
	    Asm::Ins loc_pop_rewind
	    Asm::Ins status_negate
	} $expression
    } else {
	Asm::Function [Asm::NewBlock notahead] {
	    # The sub-expression cannot generate AST elements. We can
	    # ignore AS/ARS, simplifying the code.

	    Asm::Ins loc_push

	    Asm::Call $expression

	    Asm::Ins loc_pop_rewind
	    Asm::Ins status_negate
	} $expression
    }
    Asm::Done
}

proc ::pt::peg::to::param::Op::? {modes expression} {
    # Note: This operation could be inlined, as it has no special
    #       control flow. Not done to make the higher-level ops are
    #       similar in construction and use => consistent and simple.

    Asm::Start
    Asm::ReExpression ? $expression
    Asm::GenAST $expression

    Asm::Function [Asm::NewBlock optional] {
	Asm::Ins loc_push
	Asm::Ins error_push

	Asm::Call $expression

	Asm::Ins error_pop_merge
	Asm::Ins fail! loc_pop_rewind
	Asm::Ins ok!   loc_pop_discard
	Asm::Ins status_ok
    } $expression
    Asm::Done
}

proc ::pt::peg::to::param::Op::* {modes expression} {
    Asm::Start
    Asm::ReExpression * $expression
    Asm::GenAST $expression

    Asm::Function [Asm::NewBlock kleene] {
	set failed [Asm::NewLabel failed]

	Asm::Ins loc_push
	Asm::Ins error_push

	Asm::Call $expression

	Asm::Ins error_pop_merge
	Asm::Ins fail! jump $failed
	Asm::Ins loc_pop_discard
	Asm::Ins jump [Asm::LastId] ; # Loop head = Function head.

	# FAILED, clean up and return OK.
	Asm::Label $failed
	Asm::Ins loc_pop_rewind
	Asm::Ins status_ok
    } $expression
    Asm::Done
}

proc ::pt::peg::to::param::Op::+ {modes expression} {
    Asm::Start
    Asm::ReExpression + $expression
    Asm::GenAST $expression

    Asm::Function [Asm::NewBlock poskleene] {
	set failed   [Asm::NewLabel failed]
	set loophead [Asm::NewLabel loop]

	Asm::Ins loc_push

	Asm::Call $expression

	# FAILED truly.
	Asm::Ins fail! jump $failed

	Asm::Label $loophead
	Asm::Ins loc_pop_discard
	Asm::Ins loc_push
	Asm::Ins error_push

	Asm::Call $expression

	Asm::Ins error_pop_merge
	Asm::Ins ok! jump $loophead
	# FAILED, clean up and return OK.
	Asm::Ins status_ok

	Asm::Label $failed
	Asm::Ins loc_pop_rewind
    } $expression
    Asm::Done
}

proc ::pt::peg::to::param::Op::x {modes args} {
    if {[llength $args] == 1} {
	return [lindex $args 0]
    }

    Asm::Start
    Asm::ReExpression x {*}$args
    set gens [Asm::GenAST {*}$args]

    # We have three possibilities regarding AST node generation, each
    # requiring a slightly different instruction sequence.

    # i.  gen     == 0  <=> No node generation at all.
    # ii. gens[0] == 1  <=> We may have nodes from the beginning.
    # iii.              <=> Node generation starts in the middle.

    if {![dict get $result gen]} {
	set mode none
    } elseif {[lindex $gens 0]} {
	set mode all
    } else {
	set mode some
    }

    Asm::Function [Asm::NewBlock sequence] {

	set failed [Asm::NewLabel failed]
	if {$mode eq "some"} {
	    set failed_noast [Asm::NewLabel failednoast]
	}

	switch -exact -- $mode {
	    none {
		# (Ad i) No AST node generation at all.

		Asm::Ins loc_push
		Asm::Ins error_clear
		text::write /line

		# Note: This loop runs at code generation time. At
		# runtime the entire construction is essentially a
		# fully unrolled loop, with each iteration having its
		# own block of instructions.

		foreach expression $args {
		    Asm::Ins error_push

		    Asm::Call $expression

		    Asm::Ins error_pop_merge
		    # Stop the sequence on element failure
		    Asm::Ins fail! jump $failed
		}

		# All elements OK, squash backtracking state
		text::write /line
		Asm::Ins loc_pop_discard
		Asm::Ins return

		# An element failed, restore state to before we tried
		# the sequence.
		Asm::Label $failed
		Asm::Ins loc_pop_rewind
	    }
	    all {
		# (Ad ii) AST node generation from start to end.

		Asm::Ins ast_push
		Asm::Ins loc_push
		Asm::Ins error_clear
		text::write /line

		# Note: This loop runs at code generation time. At
		# runtime the entire construction is essentially a
		# fully unrolled loop, with each iteration having its
		# own block of instructions.

		foreach expression $args {
		    Asm::Ins error_push

		    Asm::Call $expression

		    Asm::Ins error_pop_merge
		    # Stop the sequence on element failure
		    Asm::Ins fail! jump $failed
		}

		# All elements OK, squash backtracking state
		text::write /line
		Asm::Ins ast_pop_discard
		Asm::Ins loc_pop_discard
		Asm::Ins return

		# An element failed, restore state to before we tried
		# the sequence.
		Asm::Label $failed
		Asm::Ins ast_pop_rewind
		Asm::Ins loc_pop_rewind
	    }
	    some {
		# (Ad iii). Start without AST nodes, later parts do
		# AST nodes.

		Asm::Ins loc_push
		Asm::Ins error_clear
		text::write /line

		# Note: This loop runs at code generation time. At
		# runtime the entire construction is essentially a
		# fully unrolled loop, with each iteration having its
		# own block of instructions.

		set pushed 0
		foreach expression $args xgen $gens {
		    if {!$pushed && $xgen} {
			Asm::Ins ast_push
			set pushed 1
		    }

		    Asm::Ins error_push

		    Asm::Call $expression

		    Asm::Ins error_pop_merge
		    # Stop the sequence on element failure
		    if {$pushed} {
			Asm::Ins fail! jump $failed
		    } else {
			Asm::Ins fail! jump $failed_noast
		    }
		}

		# All elements OK, squash backtracking state.
		text::write /line
		Asm::Ins ast_pop_discard
		Asm::Ins loc_pop_discard
		Asm::Ins return

		# An element failed, restore state to before we tried
		# the sequence.
		Asm::Label $failed
		Asm::Ins ast_pop_rewind
		Asm::Label $failed_noast
		Asm::Ins loc_pop_rewind
	    }
	}
    } {*}$args
    Asm::Done
}

proc ::pt::peg::to::param::Op::/ {modes args} {
    if {[llength $args] == 1} {
	return [lindex $args 0]
    }

    Asm::Start
    Asm::ReExpression / {*}$args
    set gens [Asm::GenAST {*}$args]

    if {![dict get $result genmin]} {
	# We have at least one branch without AST node generation.
	set ok_noast [Asm::NewLabel oknoast]
    } else {
	set ok_noast {}
    }
    if {[dict get $result gen]} {
	# We have at least one branch capable of generating AST nodes.
	set ok [Asm::NewLabel ok]
    } else {
	set ok {}
    }

    # Optimized AST handling: Handle each branch separately, based on
    # its ability to generate AST nodes.

    Asm::Function [Asm::NewBlock choice] {
	Asm::Ins error_clear
	text::write /line

	# Note: This loop runs at code generation time. At runtime the
	# entire construction is seentially a fully unrolled loop,
	# with each iteration having its own block of instructions.

	foreach expression $args xgen $gens {
	    if {$xgen} {
		Asm::Ins ast_push
	    }
	    Asm::Ins loc_push
	    Asm::Ins error_push

	    Asm::Call $expression

	    Asm::Ins error_pop_merge
	    if {$xgen} {
		Asm::Ins ok! jump $ok
	    } else {
		Asm::Ins ok! jump $ok_noast
	    }
	    text::write /line
	    if {$xgen} {
		Asm::Ins ast_pop_rewind
	    }
	    Asm::Ins loc_pop_rewind
	}

	# All branches FAILED
	Asm::Ins status_fail
	Asm::Ins return

	# A branch was successful, squash the backtracking state
	if {$ok ne {}} {
	    Asm::Label $ok
	    Asm::Ins ast_pop_discard
	}
	if {$ok_noast ne {}} {
	    Asm::Label $ok_noast
	}
	Asm::Ins loc_pop_discard
    } {*}$args
    Asm::Done
}

# ### ### ### ######### ######### #########
## Allocate a text block / internal symbol / function

namespace eval ::pt::peg::to::param::Op::Asm {}

proc ::pt::peg::to::param::Op::Asm::Start {} {
    upvar 1 result result
    set result {def {} use {} gen 0 pe {}}
    return
}

proc ::pt::peg::to::param::Op::Asm::Done {} {
    upvar 1 result result
    return -code return $result
    return
}

proc ::pt::peg::to::param::Op::Asm::ReExpression {op args} {
    upvar 1 result result

    set pe $op
    foreach a $args {
	lappend pe [dict get $a pe]
    }

    dict set result pe $pe
    PE $pe
    return
}

proc ::pt::peg::to::param::Op::Asm::ReTerminal {op args} {
    upvar 1 result result

    set pe [linsert $args 0 $op]
    dict set result pe $pe
    PE $pe
    return
}

proc ::pt::peg::to::param::Op::Asm::GenAST {args} {
    upvar 1 result result

    foreach a $args {
	lappend flags [dict get $a gen]
    }

    dict set result gen    [tcl::mathfunc::max {*}$flags]
    dict set result genmin [tcl::mathfunc::min {*}$flags]
    return $flags
}

proc ::pt::peg::to::param::Op::Asm::NewBlock {type} {
    variable counter
    variable lastid ${type}_[incr counter]
    return $lastid
}

proc ::pt::peg::to::param::Op::Asm::NewLabel {{prefix {label}}} {
    variable counter
    return ${prefix}_[incr counter]
}

proc ::pt::peg::to::param::Op::Asm::Function {name def args} {
    upvar 1 result result
    variable ::pt::peg::to::param::compact
    variable cache

    set k [list [dict get $result gen] [dict get $result pe]]

#puts $name///<<$k>>==[info exists cache($k)]\t\t($result)

    if {$compact && [info exists cache($k)]} {
	dict set result def {}
	dict set result use $cache($k)
	return
    }

    text::write clear
    if {[text::write exists FUN_HEADER]} {
	text::write recall FUN_HEADER
	text::write undef  FUN_HEADER
    }

    Label $name
    text::write recall PE ; # Generated in Asm::Zip, printed rep
    text::write undef  PE ; # of the expression, for code clarity

    uplevel 1 $def
    Ins return

    if {[llength $args]} {
	Use {*}$args
    }

    text::write store $name

    set useb [NewBlock anon]
    text::write clear
    Ins call $name
    text::write store $useb

    dict set result def $name
    dict set result use $useb

    set cache($k) $useb
    return
}

proc ::pt::peg::to::param::Op::Asm::Direct {use} {
    upvar 1 result result

    set useb [NewBlock anon]
    text::write clear
    uplevel 1 $use
    text::write store $useb

    dict set result def {}
    dict set result use $useb
    return
}

proc ::pt::peg::to::param::Op::Asm::Call {expr {distance 1}} {
    if {$distance} { text::write /line }
    text::write recall [dict get $expr use]
    if {$distance} { text::write /line }
    return
}

proc ::pt::peg::to::param::Op::Asm::Use {args} {
    foreach item $args {
	set def [dict get $item def]
	if {$def eq {}} continue
	text::write recall $def
	text::write undef  $def
    }
    return
}

proc ::pt::peg::to::param::Op::Asm::Ins {args} {
    variable fieldlen

    if {[string match *! [lindex $args 0]]} {
	set args [lassign $args guard]
	text::write fieldr 8 $guard
    } else {
	text::write fieldr 8 {}
    }
    foreach w $args len $fieldlen {
	text::write fieldl $len $w
    }
    text::write /line
    return
}

proc ::pt::peg::to::param::Op::Asm::Label {label} {
    text::write /line
    text::write field ${label}:
    text::write /line
    return
}

proc ::pt::peg::to::param::Op::Asm::LastId {} {
    variable lastid
    return $lastid
}

proc ::pt::peg::to::param::Op::Asm::Header {text} {
    text::write field "#"
    text::write /line
    text::write field "# $text"
    text::write /line
    text::write field "#"
    text::write /line
    #text::write /line
    return
}

proc ::pt::peg::to::param::Op::Asm::PE {pe} {
    text::write clear
    text::write field [pt::pe print $pe]
    text::write /line
    text::write prefix "# "
    text::write /line
    text::write store PE
    return
}

proc ::pt::peg::to::param::Op::Asm::Setup {} {
    variable counter 0
    variable fieldlen {17 5 5}
    variable cache
    array unset cache *
    return
}

# ### ### ### ######### ######### #########
## Configuration

namespace eval ::pt::peg::to::param {
    namespace eval ::pt::peg::to::param::Op::Asm {
	variable counter 0
	variable fieldlen {17 5 5}
	variable  cache
	array set cache {}
    }

    variable inline   1            ; # A boolean flag. Specifies if we
				     # should inline terminal tests
				     # (default), or put them into
				     # their own functions.
    variable compact  1            ; # A boolean flag. Specifies if we
				     # should try to coalesce
				     # identical parsing expressions,
				     # i.e. compile them once
				     # (default), or not.
    variable template @code@       ; # A string. Specifies how to
				     # embed the generated code into a
				     # larger frame- work (the
				     # template).
    variable name     a_pe_grammar ; # String. Name of the grammar.
    variable file     unknown      ; # String. Name of the file or
				     # other entity the grammar came
				     # from.
    variable user     unknown      ; # String. Name of the user on
				     # which behalf the conversion has
				     # been invoked.
}

# ### ### ### ######### ######### #########
## Ready

package provide pt::peg::to::param 1.0.1
return