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
|
# -*- tcl -*-
#
# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
# Grammars / Parsing Expression Grammars / Parser Generator
# ### ### ### ######### ######### #########
## Package description
# A package exporting a parser generator command.
# ### ### ### ######### ######### #########
## Requisites
package require Tcl 8.5
package require fileutil
package require pt::peg::from::json ; # Frontends: json, and PEG text form
package require pt::peg::from::peg ; #
package require pt::peg::to::container ; # Backends: json, peg, container code,
package require pt::peg::to::json ; # param assembler,
package require pt::peg::to::peg ; #
package require pt::peg::to::param ; # PARAM assembly, raw
package require pt::peg::to::tclparam ; # PARAM assembly, embedded into Tcl
package require pt::peg::to::cparam ; # PARAM assembly, embedded into C
package require pt::tclparam::configuration::snit ; # PARAM/Tcl, snit::type
package require pt::tclparam::configuration::tcloo ; # PARAM/Tcl, TclOO class
package require pt::cparam::configuration::critcl ; # PARAM/C, in critcl
# ### ### ### ######### ######### #########
## Implementation
namespace eval ::pt::pgen {
namespace export json peg serial
namespace ensemble create
}
# # ## ### ##### ######## #############
## Public API - Processing the input.
proc ::pt::pgen::serial {input args} {
#lappend args -file $inputfile
return [Write {*}$args $input]
}
proc ::pt::pgen::json {input args} {
#lappend args -file $inputfile
return [Write {*}$args [pt::peg::from::json convert $input]]
}
proc ::pt::pgen::peg {input args} {
#lappend args -file $inputfile
return [Write {*}$args [pt::peg::from::peg convert $input]]
}
# # ## ### ##### ######## #############
## Internals - Generating the parser.
namespace eval ::pt::pgen::Write {
namespace export json peg container param snit oo critcl c
namespace ensemble create
}
proc ::pt::pgen::Write::json {args} {
# args = (option value)... grammar
pt::peg::to::json configure {*}[lrange $args 0 end-1]
return [pt::peg::to::json convert [lindex $args end]]
}
proc ::pt::pgen::Write::peg {args} {
# args = (option value)... grammar
pt::peg::to::peg configure {*}[lrange $args 0 end-1]
return [pt::peg::to::peg convert [lindex $args end]]
}
proc ::pt::pgen::Write::container {args} {
# args = (option value)... grammar
pt::peg::to::container configure {*}[lrange $args 0 end-1]
return [pt::peg::to::container convert [lindex $args end]]
}
proc ::pt::pgen::Write::param {args} {
# args = (option value)... grammar
pt::peg::to::param configure {*}[lrange $args 0 end-1]
return [pt::peg::to::param convert [lindex $args end]]
}
proc ::pt::pgen::Write::snit {args} {
# args = (option value)... grammar
pt::peg::to::tclparam configure {*}[Package [Class [lrange $args 0 end-1]]]
ClassPackageDefaults
pt::tclparam::configuration::snit def \
$class $package \
{pt::peg::to::tclparam configure}
return [pt::peg::to::tclparam convert [lindex $args end]]
}
proc ::pt::pgen::Write::oo {args} {
# args = (option value)... grammar
pt::peg::to::tclparam configure {*}[Package [Class [lrange $args 0 end-1]]]
ClassPackageDefaults
pt::tclparam::configuration::tcloo def \
$class $package \
{pt::peg::to::tclparam configure}
return [pt::peg::to::tclparam convert [lindex $args end]]
}
proc ::pt::pgen::Write::critcl {args} {
# args = (option value)... grammar
# Class -> touches/defines variable 'class'
# Package -> touches/defines variable 'package'
pt::peg::to::cparam configure {*}[Package [Class [lrange $args 0 end-1]]]
ClassPackageDefaults
pt::cparam::configuration::critcl def \
$class $package \
{pt::peg::to::cparam configure}
return [pt::peg::to::cparam convert [lindex $args end]]
}
proc ::pt::pgen::Write::c {args} {
# args = (option value)... grammar
pt::peg::to::cparam configure {*}[lrange $args 0 end-1]
return [pt::peg::to::cparam convert [lindex $args end]]
}
# ### ### ### ######### ######### #########
## Internals: Special option handling handling.
proc ::pt::pgen::Write::ClassPackageDefaults {} {
upvar 1 class class
upvar 1 package package
# Initialize undefined class and package names from each other,
# i.e. from whichever of the two was specified, or fallback to
# hardwired defaults if neither was specified.
if {[info exists class] && ![info exists package]} {
set package $class
} elseif {[info exists package] && ![info exists class]} {
set class $package
} elseif {![info exists package] && ![info exists class]} {
set class CLASS
set package PACKAGE
}
return
}
proc ::pt::pgen::Write::Class {optiondict} {
upvar 1 class class
set res {}
foreach {option value} $optiondict {
if {$option eq "-class"} {
set class $value
continue
}
lappend res $option $value
}
return $res
}
proc ::pt::pgen::Write::Package {optiondict} {
upvar 1 package package
set res {}
foreach {option value} $optiondict {
if {$option eq "-package"} {
set package $value
continue
}
lappend res $option $value
}
return $res
}
# ### ### ### ######### ######### #########
## Package Management
package provide pt::pgen 1.0.2
|
