Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
297 lines (233 sloc) 5.58 KB
#
# _main
#
# Setup the information the interpreter needs to run,
# then parse and interpret/compile the tcl code we were passed.
.loadlib 'tcl_ops'
.loadlib 'bit_ops' # from parrot
.loadlib 'io_ops' # from parrot
.loadlib 'trans_ops' # from parrot
.include 'hllmacros.pir'
.HLL 'tcl'
.loadlib 'tcl_group'
.include 'src/returncodes.pasm'
.include 'src/macros.pir'
.macro set_tcl_argv()
.argc()
.local pmc tcl_argv
tcl_argv = new 'TclList'
.local int ii,jj
ii = 1
jj = 0
.label $argv_loop:
if ii >= argc goto .$argv_loop_done
$P0 = argv[ii]
tcl_argv[jj] = $P0
inc ii
inc jj
goto .$argv_loop
.label $argv_loop_done:
set_global '$argv', tcl_argv
.endm
.sub _main :main
.param pmc argv
load_bytecode 'runtime/tcllib.pbc'
.local pmc retval
.local string mode,contents,filename
.local int retcode
.local pmc tcl_interactive
tcl_interactive = box 0
set_global '$tcl_interactive', tcl_interactive
.local pmc compileTcl
compileTcl = get_root_global ['_tcl'], 'compileTcl'
.local pmc get_options
get_options = new ['Getopt'; 'Obj']
push get_options, 'e=s'
push get_options, 'q'
.local pmc opt
$S0 = shift argv # drop "tcl.pbc"
opt = get_options.'get_options'(argv)
.int(quick, {defined opt['q']})
.IfElse(quick, {
$P0 = box 1
}, {
$P0 = box 0
})
set_root_global ['_tcl'], '$quick', $P0
.local int execute
execute = defined opt['e']
if execute goto oneliner
.argc()
if argc >0 goto open_file
tcl_interactive = 1
# If no file was specified, read from stdin.
load_init_tcl()
.local string input_line
.local pmc STDIN
STDIN = getstdin
input_line = ''
.local int level
level = 1
input_loop:
$P0 = prompt(level)
if null $P0 goto done
$S0 = $P0
$S0 .= "\n" # add back in the newline the prompt chomped
input_line .= $S0
execute_line:
push_eh loop_error
$P2 = compileTcl(input_line)
retval = $P2()
pop_eh
# print out the result of the evaluation.
if_null retval, input_loop_continue
if retval == '' goto input_loop_continue
say retval
goto input_loop_continue
loop_error:
.catch()
.get_severity($I0)
if $I0 != .EXCEPT_EXIT goto loop_ok
.rethrow()
loop_ok:
.local string exception_msg
.get_message(exception_msg)
# Are we just missing a close-foo?
if exception_msg == 'missing close-brace' goto input_loop_continue2
if exception_msg == 'missing close-bracket' goto input_loop_continue2
if exception_msg == 'missing "' goto input_loop_continue2
loop_error_real:
.get_stacktrace($S0)
print $S0
input_loop_continue:
level = 1
input_line = ''
goto input_loop
input_loop_continue2:
level = 2
goto input_loop
open_file:
tcl_interactive = 0
file:
filename = shift argv
$P0 = new 'TclString'
$P0 = filename
set_root_global ['_tcl'], '$script', $P0
.local string contents
$P99 = open filename, 'r'
contents = $P99.'readall'()
.set_tcl_argv()
run_file:
push_eh file_error
load_init_tcl()
$P2 = compileTcl(contents, 'bsnl' => 1)
$P2()
pop_eh
goto done
badfile:
$S0 = "couldn't read file \""
$S0 = $S0 . filename
$S0 = $S0 . '": no such file or directory'
die $S0
oneliner:
.set_tcl_argv()
load_init_tcl()
.local string tcl_code
tcl_code = opt['e']
$P3 = compileTcl(tcl_code)
push_eh file_error
$P3()
pop_eh
done:
exit 0
file_error:
.catch()
.get_severity($I0)
if $I0 == .EXCEPT_EXIT goto exit_exception
.get_return_code($I0)
if $I0 == .CONTROL_CONTINUE goto continue_outside_loop
if $I0 == .CONTROL_BREAK goto break_outside_loop
.get_stacktrace($S0)
print $S0
exit 0 # XXX wrong exit value
continue_outside_loop:
say 'invoked "continue" outside of a loop'
exit 0 # XXX should be a tcl_error
break_outside_loop:
say 'invoked "break" outside of a loop'
exit 0 # XXX should be a tcl_error
exit_exception:
.rethrow()
.end
.sub prompt
.param int level
.local pmc STDOUT
STDOUT = getstdout
.local pmc STDIN
STDIN = getstdin
.local string default_prompt
default_prompt = ''
if level == 2 goto got_prompt
default_prompt = '% '
got_prompt:
.local string varname
varname = '$tcl_prompt'
$S0 = level
varname .= $S0
.local pmc compileTcl
compileTcl = get_root_global ['_tcl'], 'compileTcl'
# XXX Should trap the printed output here, and then display
# it using the readilne prompt, like everything else.
# XXX Should be testing this
push_eh no_prompt
$P0 = get_global varname
$P2 = compileTcl($P0)
$P2()
pop_eh
STDOUT.'flush'()
# tailcall fails here.
push_eh eof
$S0 = STDIN.'readline'()
pop_eh
.return($S0)
no_prompt:
.catch()
STDOUT.'flush'()
# tailcall fails here.
push_eh eof
$S0 = STDIN.'readline_interactive'(default_prompt)
pop_eh
.return ($S0)
eof:
.catch()
null $P0
.return($P0)
.end
# load and run init.tcl
.sub load_init_tcl
$P0 = get_root_global ['_tcl'], '$quick'
.Unless($P0, {
.include 'iglobals.pasm'
.local pmc tcl_library, config, interp
tcl_library = get_global '$tcl_library'
interp = getinterp
config = interp[.IGLOBALS_CONFIG_HASH]
.local string slash
slash = config['slash']
$S0 = tcl_library
$S0 .= slash
$S0 .= 'init.tcl'
.local pmc script
$P99 = open $S0, 'r'
$S0 = $P99.'readall'()
script = get_root_global ['_tcl'], 'compileTcl'
# compile to PIR and put the sub(s) in place...
$P1 = script($S0, 'bsnl'=>1)
$P1()
})
.end
# Local Variables:
# mode: pir
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4 ft=pir:
Jump to Line
Something went wrong with that request. Please try again.