Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 297 lines (233 sloc) 5.719 kb
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
1 #
2 # _main
3 #
4 # Setup the information the interpreter needs to run,
5 # then parse and interpret/compile the tcl code we were passed.
6
7 .loadlib 'tcl_ops'
937f31f @coke track dynop migration
coke authored
8 .loadlib 'bit_ops' # from parrot
9 .loadlib 'io_ops' # from parrot
10 .loadlib 'trans_ops' # from parrot
11
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
12
598ecb3 Support -q command line option.
wcoleda authored
13 .include 'hllmacros.pir'
14
1e172fb .HLL is /sometimes/ case sensitive; just always use lowercase.
wcoleda authored
15 .HLL 'tcl'
12aefe0 Update PIR syntax to avoid recently removed syntax.
wcoleda authored
16 .loadlib 'tcl_group'
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
17
72b645a Move closer to building against an installed parrot.
wcoleda authored
18 .include 'src/returncodes.pasm'
19 .include 'src/macros.pir'
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
20
21 .macro set_tcl_argv()
c864f99 add .argc() macro
wcoleda authored
22 .argc()
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
23 .local pmc tcl_argv
2aba864 convert root_new back to new
wcoleda authored
24 tcl_argv = new 'TclList'
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
25 .local int ii,jj
26 ii = 1
27 jj = 0
28 .label $argv_loop:
29 if ii >= argc goto .$argv_loop_done
30 $P0 = argv[ii]
31 tcl_argv[jj] = $P0
32 inc ii
33 inc jj
34 goto .$argv_loop
35 .label $argv_loop_done:
25c63d2 eliminate use of some deprecated parrot opcodes that have alternatives.
wcoleda authored
36 set_global '$argv', tcl_argv
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
37 .endm
38
39 .sub _main :main
40 .param pmc argv
41
5fc9d96 We don't live in "languages/tcl" anymore.
wcoleda authored
42 load_bytecode 'runtime/tcllib.pbc'
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
43
44 .local pmc retval
45 .local string mode,contents,filename
c864f99 add .argc() macro
wcoleda authored
46 .local int retcode
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
47
48 .local pmc tcl_interactive
f1d9a70 Take advantage of the new 'box' opcode;
wcoleda authored
49 tcl_interactive = box 0
25c63d2 eliminate use of some deprecated parrot opcodes that have alternatives.
wcoleda authored
50 set_global '$tcl_interactive', tcl_interactive
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
51
52 .local pmc compileTcl
53 compileTcl = get_root_global ['_tcl'], 'compileTcl'
54
55 .local pmc get_options
4afc153 @coke Track change to parrot's stdlib namespaces.
coke authored
56 get_options = new ['Getopt'; 'Obj']
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
57 push get_options, 'e=s'
598ecb3 Support -q command line option.
wcoleda authored
58 push get_options, 'q'
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
59
60 .local pmc opt
61 $S0 = shift argv # drop "tcl.pbc"
62 opt = get_options.'get_options'(argv)
63
598ecb3 Support -q command line option.
wcoleda authored
64 .int(quick, {defined opt['q']})
65 .IfElse(quick, {
66 $P0 = box 1
67 }, {
68 $P0 = box 0
69 })
70 set_root_global ['_tcl'], '$quick', $P0
71
14f695e remove the -pir option; (Since most of our work is runtime dispatch, thi...
wcoleda authored
72 .local int execute
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
73 execute = defined opt['e']
74
75 if execute goto oneliner
76
c864f99 add .argc() macro
wcoleda authored
77 .argc()
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
78 if argc >0 goto open_file
79
80 tcl_interactive = 1
81
82 # If no file was specified, read from stdin.
1d805b7 automatically load 'init.tcl' on interpreter startup.
wcoleda authored
83 load_init_tcl()
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
84
85 .local string input_line
86 .local pmc STDIN
87 STDIN = getstdin
88
89 input_line = ''
90
91 .local int level
92 level = 1
93 input_loop:
6d71d98 Fix issue 70; interactive mode works again.
wcoleda authored
94 $P0 = prompt(level)
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
95 if null $P0 goto done
96 $S0 = $P0
97 $S0 .= "\n" # add back in the newline the prompt chomped
98 input_line .= $S0
14f695e remove the -pir option; (Since most of our work is runtime dispatch, thi...
wcoleda authored
99
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
100 execute_line:
101 push_eh loop_error
102 $P2 = compileTcl(input_line)
103 retval = $P2()
104 pop_eh
105 # print out the result of the evaluation.
106 if_null retval, input_loop_continue
107 if retval == '' goto input_loop_continue
108 say retval
109 goto input_loop_continue
110
111 loop_error:
112 .catch()
5dcd88d Allow [exit] to leave the REPL
wcoleda authored
113
114 .get_severity($I0)
115 if $I0 != .EXCEPT_EXIT goto loop_ok
116 .rethrow()
117
118 loop_ok:
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
119 .local string exception_msg
120 .get_message(exception_msg)
121 # Are we just missing a close-foo?
122 if exception_msg == 'missing close-brace' goto input_loop_continue2
123 if exception_msg == 'missing close-bracket' goto input_loop_continue2
124 if exception_msg == 'missing "' goto input_loop_continue2
125
126 loop_error_real:
127 .get_stacktrace($S0)
128 print $S0
129
130 input_loop_continue:
131 level = 1
132 input_line = ''
133 goto input_loop
134
135 input_loop_continue2:
136 level = 2
137 goto input_loop
138
139 open_file:
140 tcl_interactive = 0
141
142 file:
143 filename = shift argv
2aba864 convert root_new back to new
wcoleda authored
144 $P0 = new 'TclString'
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
145 $P0 = filename
146 set_root_global ['_tcl'], '$script', $P0
147 .local string contents
724e762 Now that parrot's TT #10 has a workaround in place, we can once again
wcoleda authored
148 $P99 = open filename, 'r'
149 contents = $P99.'readall'()
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
150
151 .set_tcl_argv()
152
153 run_file:
154 push_eh file_error
1d805b7 automatically load 'init.tcl' on interpreter startup.
wcoleda authored
155 load_init_tcl()
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
156 $P2 = compileTcl(contents, 'bsnl' => 1)
157 $P2()
158 pop_eh
159 goto done
160
161 badfile:
162 $S0 = "couldn't read file \""
163 $S0 = $S0 . filename
164 $S0 = $S0 . '": no such file or directory'
165 die $S0
166
167 oneliner:
168 .set_tcl_argv()
169
1d805b7 automatically load 'init.tcl' on interpreter startup.
wcoleda authored
170 load_init_tcl()
171
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
172 .local string tcl_code
173 tcl_code = opt['e']
174 $P3 = compileTcl(tcl_code)
175 push_eh file_error
176 $P3()
177 pop_eh
178
179 done:
5fba2d5 Avoid parrot RT#57088; 'make test' now runs clean.
wcoleda authored
180 exit 0
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
181
182 file_error:
183 .catch()
184 .get_severity($I0)
185
186 if $I0 == .EXCEPT_EXIT goto exit_exception
187 .get_return_code($I0)
188 if $I0 == .CONTROL_CONTINUE goto continue_outside_loop
189 if $I0 == .CONTROL_BREAK goto break_outside_loop
190 .get_stacktrace($S0)
191 print $S0
5fba2d5 Avoid parrot RT#57088; 'make test' now runs clean.
wcoleda authored
192 exit 0 # XXX wrong exit value
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
193
194 continue_outside_loop:
195 say 'invoked "continue" outside of a loop'
5fba2d5 Avoid parrot RT#57088; 'make test' now runs clean.
wcoleda authored
196 exit 0 # XXX should be a tcl_error
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
197
198 break_outside_loop:
199 say 'invoked "break" outside of a loop'
5fba2d5 Avoid parrot RT#57088; 'make test' now runs clean.
wcoleda authored
200 exit 0 # XXX should be a tcl_error
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
201
202 exit_exception:
203 .rethrow()
204 .end
205
206 .sub prompt
207 .param int level
208
209 .local pmc STDOUT
210 STDOUT = getstdout
211 .local pmc STDIN
212 STDIN = getstdin
213
214 .local string default_prompt
215 default_prompt = ''
216 if level == 2 goto got_prompt
217 default_prompt = '% '
218
219 got_prompt:
220
221 .local string varname
222 varname = '$tcl_prompt'
223 $S0 = level
224 varname .= $S0
225
226 .local pmc compileTcl
227 compileTcl = get_root_global ['_tcl'], 'compileTcl'
228
229 # XXX Should trap the printed output here, and then display
230 # it using the readilne prompt, like everything else.
231 # XXX Should be testing this
232 push_eh no_prompt
25c63d2 eliminate use of some deprecated parrot opcodes that have alternatives.
wcoleda authored
233 $P0 = get_global varname
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
234 $P2 = compileTcl($P0)
235 $P2()
236 pop_eh
237
6d71d98 Fix issue 70; interactive mode works again.
wcoleda authored
238 STDOUT.'flush'()
239 # tailcall fails here.
240 push_eh eof
241 $S0 = STDIN.'readline'()
242 pop_eh
243 .return($S0)
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
244
245 no_prompt:
6d71d98 Fix issue 70; interactive mode works again.
wcoleda authored
246 .catch()
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
247 STDOUT.'flush'()
6d71d98 Fix issue 70; interactive mode works again.
wcoleda authored
248 # tailcall fails here.
249 push_eh eof
250 $S0 = STDIN.'readline_interactive'(default_prompt)
251 pop_eh
252 .return ($S0)
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
253
254 eof:
6d71d98 Fix issue 70; interactive mode works again.
wcoleda authored
255 .catch()
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
256 null $P0
257 .return($P0)
258 .end
259
1d805b7 automatically load 'init.tcl' on interpreter startup.
wcoleda authored
260 # load and run init.tcl
261
262 .sub load_init_tcl
598ecb3 Support -q command line option.
wcoleda authored
263
264 $P0 = get_root_global ['_tcl'], '$quick'
265 .Unless($P0, {
266
267 .include 'iglobals.pasm'
268 .local pmc tcl_library, config, interp
269 tcl_library = get_global '$tcl_library'
270 interp = getinterp
271 config = interp[.IGLOBALS_CONFIG_HASH]
272 .local string slash
273 slash = config['slash']
274
275 $S0 = tcl_library
276 $S0 .= slash
277 $S0 .= 'init.tcl'
278
279 .local pmc script
280 $P99 = open $S0, 'r'
281 $S0 = $P99.'readall'()
282
283 script = get_root_global ['_tcl'], 'compileTcl'
284
285 # compile to PIR and put the sub(s) in place...
286 $P1 = script($S0, 'bsnl'=>1)
287 $P1()
288 })
1d805b7 automatically load 'init.tcl' on interpreter startup.
wcoleda authored
289 .end
290
d6ead2c Initial commit from r31638 of https://svn.perl.org/parrot/trunk/language...
wcoleda authored
291
292 # Local Variables:
293 # mode: pir
294 # fill-column: 100
295 # End:
296 # vim: expandtab shiftwidth=4 ft=pir:
Something went wrong with that request. Please try again.