source: branches/blt4/builder/scripts/templates.tcl @ 2413

Last change on this file since 2413 was 2170, checked in by gah, 14 years ago
File size: 15.2 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: templates
3#
4#  This file contains routines to parse language definition files in
5#  the "templates" directory.  This defines all of the programming
6#  languages that the Builder can build main programs for.  Each
7#  language is specified as follows:
8#
9#    language NAME {
10#        main { ...template... }
11#        input pattern { script }
12#        output pattern { script }
13#    }
14#
15# ======================================================================
16#  AUTHOR:  Michael McLennan, Purdue University
17#  Copyright (c) 2004-2011  Purdue Research Foundation
18#
19#  See the file "license.terms" for information on usage and
20#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
21# ======================================================================
22package require Itcl
23package require RapptureBuilder
24
25namespace eval RapptureBuilder::templates {
26    #
27    # Set up a safe interpreter for loading language defn files...
28    #
29    variable tmplParser [interp create -safe]
30    foreach cmd [$tmplParser eval {info commands}] {
31        $tmplParser hide $cmd
32    }
33    $tmplParser alias language RapptureBuilder::templates::parse_language
34    $tmplParser alias unknown RapptureBuilder::templates::parse_tmpl_unknown
35    proc ::RapptureBuilder::templates::parse_tmpl_unknown {args} {
36        error "bad command \"[lindex $args 0]\": should be language"
37    }
38
39    #
40    # Set up a safe interpreter for loading the language definition...
41    #
42    variable langParser [interp create -safe]
43    foreach cmd [$langParser eval {info commands}] {
44        $langParser hide $cmd
45    }
46    $langParser alias extension RapptureBuilder::templates::parse_template extension
47    $langParser alias command RapptureBuilder::templates::parse_template command
48    $langParser alias makefile RapptureBuilder::templates::parse_template makefile
49
50    $langParser alias main RapptureBuilder::templates::parse_template main
51    $langParser alias input RapptureBuilder::templates::parse_pattern input
52    $langParser alias output RapptureBuilder::templates::parse_pattern output
53
54    $langParser alias unknown RapptureBuilder::templates::parse_lang_unknown
55    proc ::RapptureBuilder::templates::parse_lang_unknown {args} {
56        error "bad option \"[lindex $args 0]\": should be main, input, output"
57    }
58
59    # this variable will hold LangDef object as it is being built
60    variable currLangDef ""
61}
62
63# ----------------------------------------------------------------------
64# USAGE: RapptureBuilder::templates::init
65#
66# Called at the beginning of the Rappture builder to initialize the
67# template language system.  Loads all languages in the "templates"
68# directory within the builder to define all known languages.  After
69# this, the main program can be built by calling templates::generate.
70# ----------------------------------------------------------------------
71proc RapptureBuilder::templates::init {} {
72    # load supporting type definitions
73    set dir [file join $RapptureBuilder::library scripts templates]
74    foreach fname [glob [file join $dir *.tl]] {
75        RapptureBuilder::templates::load $fname
76    }
77
78    # if anyone tries to load again, do nothing
79    proc ::RapptureBuilder::templates::init {} { # already loaded }
80}
81
82# ----------------------------------------------------------------------
83# USAGE: RapptureBuilder::templates::load <fileName>
84#
85# Used internally to load language definition files when this package
86# is first initialized by the builder.  Processes the <fileName>
87# within the template parser.  As a side-effect of executing this
88# file, a new template language is defined.
89# ----------------------------------------------------------------------
90proc RapptureBuilder::templates::load {fname} {
91    variable tmplParser
92    variable langDefs
93
94    set fid [open $fname r]
95    set info [read $fid]
96    close $fid
97
98    if {[catch {$tmplParser eval $info} err] != 0} {
99        error $err "$err\n    (while loading object definition from file \"$fname\")"
100    }
101}
102
103# ----------------------------------------------------------------------
104# USAGE: RapptureBuilder::templates::languages
105#
106# Returns a list of languages with templates loaded by the "init"
107# procedure.  These names can be passed in to "generate" to generate
108# code for these languages.
109# ----------------------------------------------------------------------
110proc RapptureBuilder::templates::languages {} {
111    variable langDefs
112    return [array names langDefs]
113}
114
115# ----------------------------------------------------------------------
116# USAGE: RapptureBuilder::templates::generate <what> \
117#           ?-language name? ?-xmlobj obj? ?-macros <string-map>?
118#
119# Builds a string of generated information starting with <what> as
120# the main template.  This string may contain other @@NAME@@ fields,
121# which are substituted recursively until all substitutions have
122# been made.  The -language option specifies which language template
123# should be used.  The -xmlobj option gives data for the @@NAME@@
124# substitutions.
125#
126# Returns the generated string with all possible substitutions.
127# ----------------------------------------------------------------------
128proc RapptureBuilder::templates::generate {what args} {
129    variable langDefs
130
131    Rappture::getopts args params {
132        value -language ""
133        value -xmlobj ""
134        value -macros ""
135    }
136    if {[llength $args] > 0} {
137        error "wrong # args: should be \"generate what ?-language name? ?-xmlobj obj?\""
138    }
139    if {$params(-language) eq ""} {
140        error "must specify a language for the code to be generated"
141    }
142
143    set lang $params(-language)
144    if {![info exists langDefs($lang)]} {
145        error "bad -language \"$lang\": should be one of [join [lsort [array names langDefs]] {, }]"
146    }
147
148    set info [$langDefs($lang) template $what]
149    if {$info eq ""} {
150        error "no such template \"$what\""
151    }
152
153    set xmlobj $params(-xmlobj)
154
155    # produce the @@INPUTS@@ section...
156    set inputs ""
157    if {$xmlobj ne ""} {
158        foreach path [Rappture::entities -as path $xmlobj input] {
159            append inputs [$langDefs($lang) generate $xmlobj $path -code]
160        }
161    }
162
163    # produce the @@OUTPUTS@@ section...
164    set outputs ""
165    if {$xmlobj ne ""} {
166        foreach path [Rappture::entities -as path $xmlobj output] {
167            append outputs [$langDefs($lang) generate $xmlobj $path -code]
168        }
169    }
170
171    # produce the @@DECLARATIONS@@ section...
172    set decls ""
173    if {$xmlobj ne ""} {
174        foreach path [Rappture::entities -as path $xmlobj input] {
175            append decls [$langDefs($lang) generate $xmlobj $path -decl]
176        }
177        foreach path [Rappture::entities -as path $xmlobj output] {
178            append decls [$langDefs($lang) generate $xmlobj $path -decl]
179        }
180    }
181
182    # handle the @@INPUTS@@ / @@OUTPUTS@@ / @@DECLARATIONS@@ specially
183    # preserve the indent at the beginning of each line
184    foreach {macro var} {
185        @@INPUTS@@ inputs
186        @@OUTPUTS@@ outputs
187        @@DECLARATIONS@@ decls
188    } {
189        set re [format {(?:^|\n)([ \t]*)%s} $macro]
190        while {[regexp -indices $re $info match indent]} {
191            set code [set $var]
192            foreach {m0 m1} $match break
193            foreach {i0 i1} $indent break
194            if {$i1-$i0 > 0} {
195                set indent [string range $info $i0 $i1]
196                set newcode ""
197                foreach line [split $code \n] {
198                    append newcode $indent $line "\n"
199                }
200                set code [string trimright $newcode \n]
201            }
202            if {[string index $info $m0] eq "\n"} { set code "\n$code" }
203            set info [string replace $info $m0 $m1 $code]
204        }
205    }
206
207    # make substitutions for any remaining macros
208    set info [string map $params(-macros) $info]
209
210    # return the generated code
211    return $info
212}
213
214# ----------------------------------------------------------------------
215# PARSER:  RapptureBuilder::templates::parse_language
216#
217# Used internally to parse the definition of a language file:
218#
219#   language NAME {
220#       main { ...body of code... }
221#       inputs { template }
222#       outputs { template }
223#   }
224#
225# Builds an object in currLangDef and then registers the completed
226# object in the langDefs array.  This defines a known language that
227# can be used to generate a template.
228# ----------------------------------------------------------------------
229proc RapptureBuilder::templates::parse_language {name body} {
230    variable currLangDef
231    variable langDefs
232    variable langParser
233
234    set currLangDef [RapptureBuilder::templates::LangDef ::#auto $name]
235
236    if {[catch {$langParser eval $body} err] != 0} {
237        itcl::delete object $currLangDef
238        set currLangDef ""
239        error $err "\n    (while loading language definition for \"$name\")"
240    }
241
242    set langDefs($name) $currLangDef
243    set currLangDef ""
244}
245
246# ----------------------------------------------------------------------
247# PARSER:  RapptureBuilder::templates::parse_template <what> <body>
248#
249# Used internally to add the definition of program templates to the
250# current language definition:
251#
252#   main { ...template... }
253#
254# ----------------------------------------------------------------------
255proc RapptureBuilder::templates::parse_template {what body} {
256    variable currLangDef
257    $currLangDef template $what $body
258}
259
260# ----------------------------------------------------------------------
261# PARSER:  RapptureBuilder::templates::parse_pattern <which> <pattern> <script>
262#
263# Used internally to add the definition of how to input/output
264# specific objects to the current language definition:
265#
266#   input number {...script...}
267#   output * {...script...}
268#
269# Each script is executed in a context that has commands and built-in
270# variables for various bits of the current object:
271#   [attr get name] ... returns the value of attribute name
272#   $path ............. path for current object
273#   $id ............... id (name at end of path) for current object
274# ----------------------------------------------------------------------
275proc RapptureBuilder::templates::parse_pattern {which pattern body} {
276    variable currLangDef
277    $currLangDef handler $which:$pattern $body
278}
279
280
281# ----------------------------------------------------------------------
282#  CLASS: LangDef
283# ----------------------------------------------------------------------
284itcl::class RapptureBuilder::templates::LangDef {
285    constructor {name args} {
286        set _lang $name
287        eval configure $args
288    }
289
290    # used to query the name of this language
291    public method language {} {
292        return $_lang
293    }
294
295    # used to register/query a template with a specific name
296    public method template {what args} {
297        if {[llength $args] == 0} {
298            if {[info exists _frag2txt($what)]} {
299                return $_frag2txt($what)
300            }
301            return ""
302        } elseif {[llength $args] != 1} {
303            error "wrong # args: should be \"template what ?text?\""
304        }
305        set _frag2txt($what) [lindex $args 0]
306    }
307
308    # used to register a script that processes an input/output element
309    public method handler {pattern body} {
310        set i [lsearch -exact $_patterns $pattern]
311        if {$i < 0} { lappend _patterns $pattern }
312        set _pat2code($pattern) $body
313    }
314
315    # used to generate the output for a specific Rappture object in this lang
316    public method generate {xmlobj path {what "-code"}} {
317        variable genParser
318        variable genOutput ""
319        variable genDecls ""
320        variable genXmlobj $xmlobj
321        variable genPath $path
322
323        set which [lindex [split $path .] 0]
324        set type [$xmlobj element -as type $path]
325        set elem $which:$type
326
327        set code ""
328        foreach pat $_patterns {
329            if {[string match $pat $elem]} {
330                set code $_pat2code($pat)
331                break
332            }
333        }
334        if {$code eq ""} {
335            error "can't find production code for $elem"
336        }
337
338        $genParser eval [list set path $path]
339        $genParser eval [list set type $type]
340        $genParser eval [list set id [$xmlobj element -as id $path]]
341        $genParser eval $code
342
343        switch -- $what {
344            -code   { return $genOutput }
345            -decl   { return $genDecls }
346            default { error "bad option \"$what\": should be -code, -decl" }
347        }
348    }
349
350    private variable _lang ""     ;# name of this language
351    private variable _frag2txt    ;# maps fragment name => template text
352    private variable _patterns "" ;# order of patterns for _pat2code
353    private variable _pat2code    ;# maps glob pattern => script to gen output
354
355    #
356    # Set up a safe interpreter for the "generate" method...
357    #
358    private common genParser [interp create -safe]
359    $genParser alias code RapptureBuilder::templates::LangDef::cmd_code
360    $genParser alias decl RapptureBuilder::templates::LangDef::cmd_decl
361    $genParser alias attr RapptureBuilder::templates::LangDef::cmd_attr
362
363    private common genOutput ""  ;# gathers code output from genParser
364    private common genDecls ""   ;# gathers declarations from genParser
365    private common genXmlobj ""  ;# Rappture tool spec
366    private common genPath ""    ;# current path in the genXmlobj data
367
368    # like the std "puts" command, but adds output to the generated code
369    proc cmd_code {args} {
370        set nl "\n"
371        while {[llength $args] > 1} {
372            set opt [lindex $args 0]
373            set args [lrange $args 1 end]
374            if {$opt eq "-nonewline"} {
375                set nl ""
376            } else {
377                error "bad option \"$opt\": should be -nonewline"
378            }
379        }
380        if {[llength $args] != 1} {
381            error "wrong # args: should be \"puts ?-nonewline? string\""
382        }
383        append genOutput [lindex $args 0] $nl
384    }
385
386    # like the std "puts" command, but adds output to code declarations
387    proc cmd_decl {args} {
388        set nl "\n"
389        while {[llength $args] > 1} {
390            set opt [lindex $args 0]
391            set args [lrange $args 1 end]
392            if {$opt eq "-nonewline"} {
393                set nl ""
394            } else {
395                error "bad option \"$opt\": should be -nonewline"
396            }
397        }
398        if {[llength $args] != 1} {
399            error "wrong # args: should be \"puts ?-nonewline? string\""
400        }
401        append genDecls [lindex $args 0] $nl
402    }
403
404    # used to query attribute info for the current object
405    proc cmd_attr {option name} {
406        set type [$genXmlobj element -as type $genPath]
407        set ainfo [Rappture::objects::get $type -attributes]
408        if {$ainfo eq ""} {
409            error "don't know how to generate code for type \"$type\""
410        }
411
412        set found 0
413        foreach rec $ainfo {
414            if {[lindex $rec 0] eq $name} {
415                set found 1
416                break
417            }
418        }
419        if {!$found} {
420            error "bad attribute name \"$name\" for type \"$type\""
421        }
422
423        switch -- $option {
424            get {
425                array set attr [lrange $rec 1 end]
426                return [$genXmlobj get $genPath.$attr(-path)]
427            }
428            info {
429                return $rec
430            }
431            default {
432                error "bad option \"$option\": should be get, info"
433            }
434        }
435    }
436}
Note: See TracBrowser for help on using the repository browser.