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
|
# -*- tcl -*-
#
# Copyright (c) 2009-2014,2022 by Andreas Kupries <andreas.kupries@gmail.com>
# Grammars / Parsing Expression Grammars / Parser Generator
# ### ### ### ######### ######### #########
## Package description
# A package exporting a parser generator command.
# ### ### ### ######### ######### #########
## Requisites
package require Tcl 8.5 9
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 1.0.3 ; # PARAM/Tcl, snit::type
package require pt::tclparam::configuration::tcloo 1.0.5 ; # PARAM/Tcl, TclOO class
package require pt::cparam::configuration::critcl 1.0.3 ; # PARAM/C, in critcl
package require pt::cparam::configuration::tea ; # PARAM/C, in TEA
package require pt::tclparam::configuration::nx 1.0.2 ; # PARAM/Tcl, NX class
# ### ### ### ######### ######### #########
## 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 snit-sa oo oo-sa critcl c tea nx
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 [Version [Class [lrange $args 0 end-1]]]]
ClassPackageDefaults
pt::tclparam::configuration::snit def \
$class $package $version \
{pt::peg::to::tclparam configure}
return [pt::peg::to::tclparam convert [lindex $args end]]
}
proc ::pt::pgen::Write::snit-sa {args} {
# args = (option value)... grammar
pt::peg::to::tclparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
ClassPackageDefaults
pt::tclparam::configuration::snit def \
$class $package $version \
{pt::peg::to::tclparam configure}
set parser [pt::peg::to::tclparam convert [lindex $args end]]
set parser [string map [list {package require pt::rde} [Runtime pt::rde]] $parser]
return $parser
}
proc ::pt::pgen::Write::oo {args} {
# args = (option value)... grammar
pt::peg::to::tclparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
ClassPackageDefaults
pt::tclparam::configuration::tcloo def \
$class $package $version \
{pt::peg::to::tclparam configure}
return [pt::peg::to::tclparam convert [lindex $args end]]
}
proc ::pt::pgen::Write::oo-sa {args} {
# args = (option value)... grammar
pt::peg::to::tclparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
ClassPackageDefaults
pt::tclparam::configuration::tcloo def \
$class $package $version \
{pt::peg::to::tclparam configure}
set parser [pt::peg::to::tclparam convert [lindex $args end]]
set parser [string map [list {package require pt::rde::oo} [Runtime pt::rde::oo]] $parser]
return $parser
}
proc ::pt::pgen::Write::nx {args} {
# args = (option value)... grammar
pt::peg::to::tclparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
ClassPackageDefaults
pt::tclparam::configuration::nx def \
$class $package $version \
{pt::peg::to::tclparam configure}
return [pt::peg::to::tclparam convert [lindex $args end]]
}
proc ::pt::pgen::Write::tea {args} {
# args = (option value)... grammar
# Class -> touches/defines variable 'class'
# Package -> touches/defines variable 'package'
# Version -> touches/defines variable 'version'
pt::peg::to::cparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
ClassPackageDefaults
pt::cparam::configuration::tea def \
$class $package $version \
{pt::peg::to::cparam configure}
return [pt::peg::to::cparam convert [lindex $args end]]
}
proc ::pt::pgen::Write::critcl {args} {
# args = (option value)... grammar
# Class -> touches/defines variable 'class'
# Package -> touches/defines variable 'package'
# Version -> touches/defines variable 'version'
pt::peg::to::cparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
ClassPackageDefaults
pt::cparam::configuration::critcl def \
$class $package $version \
{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]]
}
proc ::pt::pgen::Write::Runtime {pkg} {
set version [lindex [lsort -dict [package versions $pkg]] end]
set runtimefile [lindex [package ifneeded $pkg $version] end]
set chan [open $runtimefile r]
set runtime [read $chan]
close $chan
# Remove a trailing global return
set runtime [string map [list "\nreturn" "\n"] $runtime]
set sep "# # ## ### ##### ######## ############# #####################"
return "\n$sep\n## $pkg RUNTIME START\n##\n\n$runtime\n\n##\n## $pkg RUNTIME END\n$sep\n\n"
}
# ### ### ### ######### ######### #########
## Internals: Special option handling handling.
proc ::pt::pgen::Write::ClassPackageDefaults {} {
upvar 1 class class
upvar 1 package package
upvar 1 version version
# 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
}
# Initialize undefined version information.
if {![info exists version]} {
set version 1
}
return
}
# Class, Package, Version - identical modulo option and variable name.
# TODO: Refactor into some common code.
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
}
proc ::pt::pgen::Write::Version {optiondict} {
upvar 1 version version
set res {}
foreach {option value} $optiondict {
if {$option eq "-version"} {
set version $value
continue
}
lappend res $option $value
}
return $res
}
# ### ### ### ######### ######### #########
## Package Management
package provide pt::pgen 1.4
|
