OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tix/] [tools/] [tclc.tcl] - Blame information for rev 1771

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
proc ParseFile {fileName n} {set fd [open $fileName {RDONLY}]
2 
set lineNum 1
3 
puts "static char script_$n\[\] = \{"
4 
set N [format \n]
5 
set T [format \t]
6 
set NTS [format "\n\t\ "]
7 
set sep ""
8 
while {![eof $fd]} {set line [gets $fd]
9 
regsub -all $N $line " " foo
10 
append foo \na
11 
set foo [subst -nocommands -novariables $foo]
12 
if [regexp $N $foo] {set cmd "$line\n"
13 
} else {regsub -all \\\\\[$NTS\]*$ $line " " line
14 
set cmd "$line"
15 
}
16 
set cmd '[join [split $cmd ""] ',']'
17 
regsub -all \\\\ $cmd \\\\\\\\ cmd
18 
regsub -all $N $cmd \\n cmd
19 
regsub -all $T $cmd \\t cmd
20 
regsub -all ''' $cmd '\\'' cmd
21 
regsub -all '\"' $cmd '\\\"' cmd
22 
puts -nonewline $sep$cmd
23 
set sep ,\n
24 
}
25 
puts "$sep'\\0'\};"
26 
close $fd
27 
}
28 
proc tclc_Main {} {global argv argv0
29 
set files [lrange $argv 0 end]
30 
set n 0
31 
foreach fileName $argv {ParseFile $fileName $n
32 
incr n
33 
}
34 
puts "static int LoadScripts(interp)"
35 
puts "    Tcl_Interp * interp;"
36 
puts "\{"
37 
if {$n > 0} {puts "    char *scripts\[$n\];"
38 
puts "    int i;"
39 
for {set k 0} {$k < $n} {incr k} {puts "    scripts\[$k\] = script_$k;"
40 
}
41 
puts "    for (i=0; i<$n; i++) \{"
42 
puts "        if (Tcl_Eval(interp, scripts\[i\]) != TCL_OK) \{"
43 
puts "            return TCL_ERROR;"
44 
puts "        \}"
45 
puts "    \}"
46 
}
47 
puts "    return TCL_OK;"
48 
puts "\}"
49 
}
50 
 
51 
proc jdb_ParseFile {fileName rewriteProc} {global jdbLines
52 
if [info exists jdbLines] {unset jdbLines
53 
}
54 
set data ""
55 
set fd [open $fileName {RDONLY}]
56 
set fileLineNum  1
57 
set scapLineNum  1
58 
set fileLineNumx 1
59 
set newLine [format \n]
60 
set NTS [format "\n\t\ "]
61 
while {![eof $fd]} {set line [gets $fd]
62 
regsub -all $newLine $line " " foo
63 
append foo \na
64 
set foo [subst -nocommands -novariables $foo]
65 
if [regexp $newLine $foo] {append data "$line\n"
66 
set jdbLines($scapLineNum) $fileLineNumx
67 
incr scapLineNum
68 
incr fileLineNum
69 
set fileLineNumx $fileLineNum
70 
} else {regsub -all \\\\\[$NTS\]*$ $line " " line
71 
append data "$line"
72 
incr fileLineNum
73 
}
74 
}
75 
close $fd
76 
global jdb_rewProc
77 
set jdb_rewProc $rewriteProc
78 
return [jdb_Rewrite $fileName 1 $data]
79 
}
80 
proc jdb_BreakCommand {lineNum script wordsName typesName lnumsName} {upvar $wordsName words
81 
upvar $typesName types
82 
upvar $lnumsName lnums
83 
set i 0
84 
set word ""
85 
set sep ""
86 
set N [format %s \n]
87 
foreach item [split $script " "] {append word $sep$item
88 
if ![string comp [string trim $word] ""] {continue
89 
}
90 
if [info complete $word] {set n [regsub -all $N $word "" dummy]
91 
set tmp [string trim $word]
92 
set len [string len $tmp]
93 
if {[string index $tmp 0] == "\{" &&
94 
                    [string index $tmp [expr $len-1]] == "\}"} {set word [string range $tmp 1 [expr $len-2]]
95 
set itemType brace
96 
} elseif {[string index $tmp 0] == "\"" &&
97 
                    [string index $tmp [expr $len-1]] == "\""} {set word [string range $tmp 1 [expr $len-2]]
98 
set itemType quote
99 
} else {set itemType none
100 
}
101 
set lnums($i) $lineNum
102 
set types($i) $itemType
103 
set words($i) $word
104 
incr lineNum $n
105 
incr i
106 
set word ""
107 
set sep ""
108 
} else {set sep " "
109 
}
110 
}
111 
if [string comp [string trim $word] ""] {error "badly formatted script\n$script"
112 
}
113 
}
114 
proc jdb_Recurse {file lineNum script} {global builtin
115 
set cmd [lindex [split $script " "]  0]
116 
if [info exists builtin($cmd)] {set script [$builtin($cmd) $file $lineNum $script]
117 
}
118 
return $script
119 
}
120 
proc jdb_JoinCommand {wordsName typesName} {upvar $wordsName words
121 
upvar $typesName types
122 
set rwt ""
123 
set sep ""
124 
foreach i [lsort -integer [array names words]] {case $types($i) {
125 
        brace {append rwt "$sep\{"
126 
append rwt "$words($i)"
127 
append rwt "\}"
128 
} quote {append rwt "$sep\""
129 
append rwt "$words($i)"
130 
append rwt "\""
131 
} default {append rwt "$sep$words($i)"
132 
}}
133 
set sep " "
134 
}
135 
return $rwt
136 
}
137 
proc jdb_Rewrite {file lineNum script} {global jdb_rewProc xxx
138 
set rewritten ""
139 
set cmd ""
140 
foreach line [split $script \n] {append cmd $line\n
141 
if [info complete $cmd] {append rewritten [$jdb_rewProc $file $lineNum $cmd]
142 
incr lineNum [regsub -all [format %s \n] $cmd "" dummy]
143 
set cmd ""
144 
}
145 
}
146 
if [string comp $cmd {}] {error "Script is not complete: \n$script"
147 
} else {return $rewritten
148 
}
149 
}
150 
set builtin(catch)   jdb_RewriteCatch
151 
set builtin(case)    jdb_RewriteCase
152 
set builtin(for)     jdb_RewriteFor
153 
set builtin(foreach) jdb_RewriteForeach
154 
set builtin(if)      jdb_RewriteIf
155 
set builtin(proc)    jdb_RewriteProc
156 
set builtin(while)   jdb_RewriteWhile
157 
proc jdb_RewriteCatch {file lineNum script} {jdb_BreakCommand $lineNum $script words types lnums
158 
if [info exists words(1)] {set words(1) [jdb_Rewrite $file $lnums(1) $words(1)]
159 
}
160 
return [jdb_JoinCommand words types]
161 
}
162 
proc jdb_RewriteCase {file lineNum script} {jdb_BreakCommand $lineNum $script words types lnums
163 
set indices [lsort -integer [array names words]]
164 
if [info exists words(2)] {if ![string comp $words(2) in] {set list [lrange $indices 3 end]
165 
} else {set list [lrange $indices 2 end]
166 
}
167 
if {[llength $list] > 1} {set len [llength $list]
168 
for {set x 1} {$x < $len} {incr x 2} {set i [lindex $list $x]
169 
set words($i) [jdb_Rewrite $file $lnums($i) $words($i)]
170 
}
171 
} else {set i [lindex $list 0]
172 
set words($i) [jdb_RewriteCaseBodyList $file $lnums($i) $words($i)]
173 
}
174 
}
175 
return [jdb_JoinCommand words types]
176 
}
177 
proc jdb_RewriteCaseBodyList {file lineNum script} {jdb_BreakCommand $lineNum $script words types lnums
178 
set indices [lsort -integer [array names words]]
179 
set len [llength $indices]
180 
for {set x 1} {$x < $len} {incr x 2} {set i [lindex $indices $x]
181 
set words($i) [jdb_Rewrite $file $lnums($i) $words($i)]
182 
}
183 
return [jdb_JoinCommand words types]
184 
}
185 
proc jdb_RewriteIf {file lineNum script} {jdb_BreakCommand $lineNum $script words types lnums
186 
set expected if
187 
foreach i [lsort -integer [array names words]] {set ln   $lnums($i)
188 
set item $words($i)
189 
case $expected {
190 
        if {set expected expr
191 
} expr {set expected stmt
192 
} stmt {if [string comp [string trim $item] "then"] {set words($i) [jdb_Rewrite $file $ln $item]
193 
set expected el_elif
194 
}
195 
} el_elif {if {$item == "elseif"} {set expected expr
196 
} else {set expected stmt
197 
}
198 
}}
199 
}
200 
return [jdb_JoinCommand words types]
201 
}
202 
proc jdb_RewriteProc {file lineNum script} {jdb_BreakCommand $lineNum $script words types lnums
203 
if [info exists words(3)] {set words(3) [jdb_Rewrite $file $lnums(3) $words(3)]
204 
}
205 
return [jdb_JoinCommand words types]
206 
}
207 
proc jdb_RewriteWhile {file lineNum script} {jdb_BreakCommand $lineNum $script words types lnums
208 
if [info exists words(2)] {set words(2) [jdb_Rewrite $file $lnums(2) $words(2)]
209 
}
210 
return [jdb_JoinCommand words types]
211 
}
212 
proc jdb_RewriteFor {file lineNum script} {jdb_BreakCommand $lineNum $script words types lnums
213 
if [info exists words(4)] {set words(4) [jdb_Rewrite $file $lnums(4) $words(4)]
214 
}
215 
return [jdb_JoinCommand words types]
216 
}
217 
proc jdb_RewriteForeach {file lineNum script} {jdb_BreakCommand $lineNum $script words types lnums
218 
if [info exists words(3)] {set words(3) [jdb_Rewrite $file $lnums(3) $words(3)]
219 
}
220 
return [jdb_JoinCommand words types]
221 
}
222 
 
223 
tclc_Main

powered by: WebSVN 2.1.0

© copyright 1999-2025 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.