parse.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
---------------------------> Sather 1.1 source file <--------------------------
-- Copyright (C) International Computer Science Institute, 1995. COPYRIGHT --
-- NOTICE: This code is provided "AS IS" WITHOUT ANY WARRANTY and is subject --
-- to the terms of the SATHER LIBRARY GENERAL PUBLIC LICENSE contained in --
-- the file "Doc/License" of the Sather distribution. The license is also --
-- available from ICSI, 1947 Center St., Suite 600, Berkeley CA 94704, USA. --
--------> Please email comments to sather-bugs@icsi.berkeley.edu. <----------
-- parse.sa: 1.1 version of parser for 1.1 Sather compiler.
class PARSE_TEST
class PARSE_TEST is
-- Test the parser out.
main(arg: ARRAY{STR}) is
if arg.size < 2 then #OUT + "Usage: " + arg[0] + " [-pSather] <files>\n" end;
#OUT + "Sather/pSather 1.0 parser - 9 Aug 94\n";
pSather: BOOL; i: INT;
if (arg.size > 1) and (arg[1] = "-pSather") then pSather := true; i := 2
else pSather := false; i := 1
end;
p ::= PROG::create;
t ::= p.parse;
parse:PARSE;
typecase t
when PARSE then parse := t;
end;
loop while!(i < arg.size);
parser ::= PARSER::create(p, arg[i], pSather, parse.convert_files.test(arg[i]), parse.version_1_0);
if ~void(parser) then
#OUT + "In file " + arg[i] + ":\n";
tcd: AS_CLASS_DEF := parser.source_file;
#OUT + "\n";
loop until!(void(tcd));
#OUT + ' ' + tcd.name.str + '\n';
tcd := tcd.next
end
end;
#OUT + "\n\n";
i := i+1
end
end
end; -- PARSE
class CONVERT
class CONVERT is
-- the following attributes are needed for translation from pre 1.1 syntax
-- to 1.1 syntax.
-- This class was designed in a such a way so that after the transition
-- period is over, it could be deleted along with all calls to its
-- method. The only other remaining thing that would need to be taken
-- care of is -convert option.
attr start_pos:INT;
attr end_pos:INT;
attr need_to_convert:BOOL;
attr file:FILE;
create(parser:PARSER, conv:BOOL, fname:STR):SAME is
res ::= new;
header_label:STR :=
"---------------------------> Sather 1.1 source file <--------------------------\n";
-- check of the file has been already converted
already_converted:BOOL;
if SFILE_ID::source.length >= header_label.length then-- SFILE_ID::source FSTR::length INT::is_lt STR::length BOOL::not
already_converted := true;
loop
if SFILE_ID::source.elt! /= header_label.elt! then-- SFILE_ID::source FSTR::elt! CHAR::is_eq STR::elt! BOOL::not
already_converted := false;
break!;
end;
end;
else
already_converted := false;
end;
res.need_to_convert := conv and ~already_converted;-- CONVERT::need_to_convert BOOL::not
if conv and already_converted then
parser.prog.set_eloc(parser.source_loc);-- PARSER::prog PROG::set_eloc PARSER::source_loc
parser.prog.warning(fname + " has been converted to 1.1 syntax previouly\n");-- PARSER::prog PROG::warning STR::plus
parser.version_1_0 := false; -- PARSER::version_1_0
end;
if parser.version_1_0 and already_converted then-- PARSER::version_1_0
parser.prog.set_eloc(parser.source_loc); -- PARSER::prog PROG::set_eloc PARSER::source_loc
parser.prog.warning(fname + " has been converted to 1.1 syntax previouly. Avoid -V1.0\n");-- PARSER::prog PROG::warning STR::plus
parser.version_1_0 := false; -- PARSER::version_1_0
end;
if res.need_to_convert then-- CONVERT::need_to_convert
-- Save the 1.0 file in filename.1.0
fp:FILE:=FILE::open_for_write(fname+".1.0");-- FILE::open_for_write STR::plus
fp + SFILE_ID::source;-- FILE::plus SFILE_ID::source
fp.close;-- FILE::close
-- now, open a new file
res.file := FILE::open_for_write(fname);-- CONVERT::file FILE::open_for_write
res.file + header_label;-- CONVERT::file FILE::plus
end;
return res;
end;
set_start is
if need_to_convert then-- CONVERT::need_to_convert
start_pos := SFILE_ID::pos-1;-- CONVERT::start_pos SFILE_ID::pos INT::minus
end;
end;
set_start(i:INT) is
if need_to_convert then-- CONVERT::need_to_convert
start_pos := 0;-- CONVERT::start_pos
end;
end;
set_end is
if need_to_convert then-- CONVERT::need_to_convert
end_pos := SFILE_ID::pos-1;-- CONVERT::end_pos SFILE_ID::pos INT::minus
write_chunk;-- CONVERT::write_chunk
end;
end;
set_end(i:INT) is
if need_to_convert then-- CONVERT::need_to_convert
end_pos := i;-- CONVERT::end_pos
write_chunk;-- CONVERT::write_chunk
end;
end;
write_chunk is
loop
i::=start_pos.upto!(end_pos);-- CONVERT::start_pos INT::upto! CONVERT::end_pos
file + SFILE_ID::source[i];-- CONVERT::file FILE::plus SFILE_ID::source FSTR::aget
end;
file.flush;-- CONVERT::file FILE::flush
end;
convert_iter_def(feature_name:IDENT) is
-- converts 1.0 syntax for iter defs to 1.1 syntax
-- More precisely, ``once'' is added for once args
-- and ``!'' is removed from hot args
-- No changes for function calls
if need_to_convert then-- CONVERT::need_to_convert
-- first, back up to the opening ``(''
i:INT := SFILE_ID::pos;-- SFILE_ID::pos
loop
while!( SFILE_ID::source[i] /= '(');-- SFILE_ID::source FSTR::aget CHAR::is_eq BOOL::not
i := i - 1;-- INT::minus
end;
set_end(i);-- CONVERT::set_end
i:=i+1;-- INT::plus
done:BOOL:=false;
loop
while!(~done);-- BOOL::not
start::=i;
hot:BOOL:=false;
c:CHAR;
loop
c:=SFILE_ID::source[i];-- SFILE_ID::source FSTR::aget
if c = '{' then-- CHAR::is_eq
-- skip parametrizations
in_param::=1;
loop
while!(in_param /= 0);-- INT::is_eq BOOL::not
i := i + 1;-- INT::plus
c := SFILE_ID::source[i];-- SFILE_ID::source FSTR::aget
if c = '{' then in_param := in_param + 1;-- CHAR::is_eq INT::plus
elsif c = '}' then in_param := in_param - 1;-- CHAR::is_eq INT::minus
end;
end;
end;
while! (~((c=',') or (c=')')));-- CHAR::is_eq CHAR::is_eq BOOL::not
if c = '!' then-- CHAR::is_eq
hot:=true;
end;
i := i + 1;-- INT::plus
end;
if c=')' then done := true; end;-- CHAR::is_eq
if ~hot then-- BOOL::not
file + "once ";-- CONVERT::file FILE::plus
end;
loop
j::=start.upto!(i);-- INT::upto!
if SFILE_ID::source[j] /= '!' then-- SFILE_ID::source FSTR::aget CHAR::is_eq BOOL::not
file + SFILE_ID::source[j];-- CONVERT::file FILE::plus SFILE_ID::source FSTR::aget
end;
end;
i:=i+1;-- INT::plus
end;
file.flush;-- CONVERT::file FILE::flush
end;
end;
back_to(ch:CHAR) is
i::=SFILE_ID::pos;-- SFILE_ID::pos
loop
while!(SFILE_ID::source[i] /= ch); -- SFILE_ID::source FSTR::aget CHAR::is_eq BOOL::not
i := i - 1;-- INT::minus
end;
set_end(i-1);-- CONVERT::set_end INT::minus
end;
convert_type_def is
-- converts ``type'' to ``abstract class'' according to 1.1 spec
-- output preceding stuff
if need_to_convert then-- CONVERT::need_to_convert
back_to('t');-- CONVERT::back_to
file + "abstract class";-- CONVERT::file FILE::plus
set_start;-- CONVERT::set_start
file.flush;-- CONVERT::file FILE::flush
end;
end;
convert_value is
-- converts ``value'' to ``immutable'' according to 1.1 spec
-- output preceding stuff
if need_to_convert then-- CONVERT::need_to_convert
back_to('v');-- CONVERT::back_to
file + "immutable class";-- CONVERT::file FILE::plus
set_start;-- CONVERT::set_start
file.flush;-- CONVERT::file FILE::flush
end;
end;
convert_bind is
-- converts "bind" and "bind" to "bind"
-- output preceding stuff
if need_to_convert then-- CONVERT::need_to_convert
back_to('#');-- CONVERT::back_to
file + "bind";-- CONVERT::file FILE::plus
set_start;-- CONVERT::set_start
file.flush;-- CONVERT::file FILE::flush
end;
end;
end;
class PARSER
class PARSER is
include LEX_CONST;
include CS_COMPONENT;
attr scanner: SCANNER;
attr next: TOKEN;
attr entered: FLIST{STR}; -- stack of grammatical procedure calls
attr convert: CONVERT;
attr version_1_0:BOOL; -- true if the file has a 1.0 syntax
create (p: PROG, file: STR, pSather: BOOL,
conv_to_1_1:BOOL, version_1_0:BOOL): PARSER is
res: PARSER;
s ::= SCANNER::create(p, file, pSather); -- SCANNER::create
if ~void(s) then-- BOOL::not
res := new;
res.prog := p;-- PARSER::prog
res.scanner := s;-- PARSER::scanner
res.next := res.scanner.token;-- PARSER::next PARSER::scanner SCANNER::token
res.entered := FLIST{STR}::create(64);-- PARSER::entered FLIST{1}::create
res.version_1_0 := version_1_0;-- PARSER::version_1_0
res.convert := #CONVERT(res, conv_to_1_1, file);-- PARSER::convert CONVERT::create
else res := void
end;
return res
end;
close_file is
scanner.close_file-- PARSER::scanner SCANNER::close_file
end;
source_loc: SFILE_ID is
return SFILE_ID::source_loc-- SFILE_ID::source_loc
end;
error (msg: STR) is
-- where errors during parsing go
prog.set_eloc(source_loc);-- PARSER::prog PROG::set_eloc PARSER::source_loc
err(msg + " (in " + entered.top + ')')-- PARSER::err STR::plus PARSER::entered FLIST{1}::top STR::plus
end;
warning (msg: STR) is
-- where errors during parsing go
prog.set_eloc(source_loc);-- PARSER::prog PROG::set_eloc PARSER::source_loc
prog.warning(msg + " (in " + entered.top + ')')-- PARSER::prog PROG::warning STR::plus PARSER::entered FLIST{1}::top STR::plus
end;
exp_error (msg: STR) is
error(msg + " expected, but found " + next.str)-- PARSER::error STR::plus PARSER::next TOKEN::str
end;
fetch is
next := scanner.token-- PARSER::next PARSER::scanner SCANNER::token
end;
match (t: INT) is
if next /= t then exp_error(#TOKEN(t).str) end;-- PARSER::next TOKEN::is_eq BOOL::not PARSER::exp_error TOKEN::create TOKEN::str
fetch-- PARSER::fetch
end;
check (t: INT): BOOL is
if next = t then fetch; return true-- PARSER::next TOKEN::is_eq PARSER::fetch
else return false
end
end;
enter (s: STR) is
-- announce beginning of syntactic structure (for nice errors)
--
entered := entered.push(s)-- PARSER::entered PARSER::entered FLIST{1}::push
end;
exit is
-- exit from syntactic structure
--
s ::= entered.pop-- PARSER::entered FLIST{1}::pop
end;
ident: IDENT is
return scanner.lex_value-- PARSER::scanner SCANNER::lex_value
end;
append_bang (arg: IDENT): IDENT is
-- make new version with trailing bang
return #IDENT(arg.str + "!")-- IDENT::create IDENT::str STR::plus
end;
is_type_or_class_start (t: TOKEN): BOOL is
case t.val-- TOKEN::val
when abstract_tok, type_tok, spread_tok, immutable_tok, value_tok,-- PARSER::abstract_tok PARSER::type_tok PARSER::spread_tok PARSER::immutable_tok PARSER::value_tok
partial_tok, external_tok, class_tok -- PARSER::partial_tok PARSER::external_tok PARSER::class_tok
then
return true
else return false
end
end;
source_file: AS_CLASS_DEF is
-- source_file =>
-- [abstract_class_def | class] {';' [abstract_class_def | class]}
--
res: AS_CLASS_DEF;
enter("source file");-- PARSER::enter
convert.set_start(0);-- PARSER::convert CONVERT::set_start
loop
if is_type_or_class_start(next) then-- PARSER::next
if (next = type_tok) or (next = abstract_tok) then-- PARSER::next PARSER::type_tok PARSER::next PARSER::abstract_tok
if (next = type_tok) and ~version_1_0 then-- PARSER::next PARSER::type_tok PARSER::version_1_0 BOOL::not
error("keyword ``type'' has been replaced with ``abstract class'' in Sather 1.1.Please, convert your file to 1.1 syntax (use -convert), or use -V1.0 option");-- PARSER::error
end;
if (next=abstract_tok) and version_1_0 then-- PARSER::next PARSER::abstract_tok PARSER::version_1_0
error("keyword ``abstract'' first appeared in Sather 1.1. Please, compile without -V1.0");-- PARSER::error
end;
convert.convert_type_def;-- PARSER::convert CONVERT::convert_type_def
if void(res) then res:=abstract_class_def-- PARSER::abstract_class_def
else res.append(abstract_class_def) end;-- AS_CLASS_DEF::append PARSER::abstract_class_def
else
if void(res) then res:=class_def-- PARSER::class_def
else res.append(class_def) end end end;-- AS_CLASS_DEF::append PARSER::class_def
if check(semi_tok) then -- ok-- PARSER::semi_tok
elsif is_type_or_class_start(next) then exp_error("semicolon")-- PARSER::next PARSER::exp_error
else
if next /= eof_tok then exp_error("end of file") end;-- PARSER::next PARSER::eof_tok BOOL::not PARSER::exp_error
break! end end;
convert.set_end;-- PARSER::convert CONVERT::set_end
close_file;-- PARSER::close_file
exit; return res-- PARSER::exit
end;
abstract_class_def: AS_CLASS_DEF is
-- abstract_class_def =>
-- 'abstract' 'class' abstract_class_name
-- ['{' param_dec {',' param_dec}'}']
-- ['<' type_spec_list] ['>' type_spec_list]
-- 'is' [abstract_signature] {';' [abstract_signature]} 'end'
--
enter("abstract type definition");-- PARSER::enter
res ::= #AS_CLASS_DEF; res.source := source_loc; res.kind := res.abs;-- AS_CLASS_DEF::create AS_CLASS_DEF::source PARSER::source_loc AS_CLASS_DEF::kind AS_CLASS_DEF::abs
if version_1_0 then-- PARSER::version_1_0
match(type_tok);-- PARSER::type_tok
else
match(abstract_tok);-- PARSER::abstract_tok
match(class_tok);-- PARSER::class_tok
end;
if check(type_name_tok) then --ok-- PARSER::type_name_tok
else exp_error("abstract type name");-- PARSER::exp_error
if next = ident_tok then fetch end-- PARSER::next PARSER::ident_tok PARSER::fetch
end;
res.name := ident;-- AS_CLASS_DEF::name PARSER::ident
if check(lbrace_tok) then-- PARSER::lbrace_tok
loop until!(next /= ident_tok);-- PARSER::next PARSER::ident_tok BOOL::not
if void(res.params) then res.params:=param_dec-- AS_CLASS_DEF::params AS_CLASS_DEF::params PARSER::param_dec
else res.params.append(param_dec) end;-- AS_CLASS_DEF::params AS_PARAM_DEC::append PARSER::param_dec
if ~check(comma_tok) then break! end end;-- PARSER::comma_tok BOOL::not
match(rbrace_tok) end;-- PARSER::rbrace_tok
if check(is_lt_tok) then res.under := type_spec_list end;-- PARSER::is_lt_tok AS_CLASS_DEF::under PARSER::type_spec_list
if check(is_gt_tok) then res.over := type_spec_list end;-- PARSER::is_gt_tok AS_CLASS_DEF::over PARSER::type_spec_list
match(is_tok);-- PARSER::is_tok
res.body := abstract_signature_list;-- AS_CLASS_DEF::body PARSER::abstract_signature_list
match(end_tok);-- PARSER::end_tok
exit;-- PARSER::exit
return res
end;
abstract_signature_list: $AS_CLASS_ELT is
-- abstract_signature_list =>
-- [abstract_signature] {';' [abstract_signature]}
--
res: $AS_CLASS_ELT;
enter("list of abstract signatures");-- PARSER::enter
loop
if (next = ident_tok) or (next = bang_tok) or-- PARSER::next PARSER::ident_tok PARSER::next PARSER::bang_tok
(next = iter_bang_tok) then-- PARSER::next PARSER::iter_bang_tok
if void(res) then res := abstract_signature-- PARSER::abstract_signature
else res.append(abstract_signature) end-- PARSER::abstract_signature
end;
if check(semi_tok) then -- ok-- PARSER::semi_tok
elsif next = ident_tok then exp_error("semicolon")-- PARSER::next PARSER::ident_tok PARSER::exp_error
else break!
end
end;
if next /= end_tok then-- PARSER::next PARSER::end_tok BOOL::not
exp_error("semicolon");-- PARSER::exp_error
loop while!((next /= end_tok) and (next /= eof_tok)); fetch end-- PARSER::next PARSER::end_tok BOOL::not PARSER::next PARSER::eof_tok BOOL::not PARSER::fetch
end;
exit;-- PARSER::exit
return res
end;
abstract_signature: AS_ROUT_DEF is
-- abstract_signature =>
-- (ident | iter_name)
-- ['(' abstract_argument {',' abstract_argument} ')']
-- [':' type_spec]
--
enter("abstract signature");-- PARSER::enter
res ::= #AS_ROUT_DEF; res.source := source_loc; res.is_abstract := true;-- AS_ROUT_DEF::create AS_ROUT_DEF::source PARSER::source_loc AS_ROUT_DEF::is_abstract
res.name := rout_or_iter_name;-- AS_ROUT_DEF::name PARSER::rout_or_iter_name
if check(lparen_tok) then-- PARSER::lparen_tok
enter("abstract arguments");-- PARSER::enter
if res.name.is_iter then-- AS_ROUT_DEF::name IDENT::is_iter
convert.convert_iter_def(res.name);-- PARSER::convert CONVERT::convert_iter_def AS_ROUT_DEF::name
end;
loop
if void(res.args_dec) then -- AS_ROUT_DEF::args_dec
res.args_dec:=abstract_argument(res.name.is_iter);-- AS_ROUT_DEF::args_dec PARSER::abstract_argument AS_ROUT_DEF::name IDENT::is_iter
else res.args_dec.append(-- AS_ROUT_DEF::args_dec AS_ARG_DEC::append
abstract_argument(res.name.is_iter)) end;-- PARSER::abstract_argument AS_ROUT_DEF::name IDENT::is_iter
while!(check(comma_tok)) -- PARSER::comma_tok
end;
if res.name.is_iter then-- AS_ROUT_DEF::name IDENT::is_iter
convert.set_start;-- PARSER::convert CONVERT::set_start
end;
match(rparen_tok);-- PARSER::rparen_tok
exit -- PARSER::exit
end;
if check(colon_tok) then -- PARSER::colon_tok
enter("return type specification");-- PARSER::enter
res.ret_dec := type_spec; -- AS_ROUT_DEF::ret_dec PARSER::type_spec
exit end;-- PARSER::exit
exit;-- PARSER::exit
return res
end;
get_mode (is_iter: BOOL):AS_ARG_MODE is
mode: INT;
if check(out_tok) then-- PARSER::out_tok
mode := AS_ARG_MODE::out_mode;-- AS_ARG_MODE::out_mode
elsif check(inout_tok) then mode := AS_ARG_MODE::inout_mode-- PARSER::inout_tok AS_ARG_MODE::inout_mode
elsif check(once_tok) then -- PARSER::once_tok
if ~is_iter then-- BOOL::not
error("once arguments are not allowed in routine declarations")-- PARSER::error
end;
mode := AS_ARG_MODE::once_mode-- AS_ARG_MODE::once_mode
else
mode := AS_ARG_MODE::in_mode;-- AS_ARG_MODE::in_mode
end;
return #AS_ARG_MODE(mode);-- AS_ARG_MODE::create
end;
abstract_argument (is_iter: BOOL): AS_ARG_DEC is
-- arg_dec => [mode ident {',' ident} ':'] type_spec ['!']
--
res: AS_ARG_DEC;
mode: AS_ARG_MODE;
enter("abstract argument");-- PARSER::enter
loop
mode := get_mode(is_iter);-- PARSER::get_mode
newa ::= #AS_ARG_DEC; newa.source := source_loc;-- AS_ARG_DEC::create AS_ARG_DEC::source PARSER::source_loc
match(ident_tok);-- PARSER::ident_tok
newa.name := ident;-- AS_ARG_DEC::name PARSER::ident
newa.mode := mode;-- AS_ARG_DEC::mode
if void(res) then res := newa
else res.append(newa)-- AS_ARG_DEC::append
end;
while!(check(comma_tok))-- PARSER::comma_tok
end;
match(colon_tok);-- PARSER::colon_tok
-- the following is temporarily kept to parse the pre 1.1 programs
-- it will have to change when the transition to 1.1 is complete
-- Boris
tp:AS_TYPE_SPEC := type_spec;-- PARSER::type_spec
hot:BOOL;
if version_1_0 then-- PARSER::version_1_0
hot := check(bang_tok) or check(iter_bang_tok);-- PARSER::bang_tok PARSER::iter_bang_tok
if hot and ~is_iter then-- BOOL::not
error("hot arguments not allowed in routine declarations")-- PARSER::error
end;
end;
p: AS_ARG_DEC := res;
loop until!(void(p));
p.tp := tp; -- AS_ARG_DEC::tp
if version_1_0 then-- PARSER::version_1_0
p.is_hot := hot; -- AS_ARG_DEC::is_hot
else
if is_iter then
p.is_hot := (p.mode.mod /= AS_ARG_MODE::once_mode)-- AS_ARG_DEC::is_hot AS_ARG_DEC::mode AS_ARG_MODE::mod INT::is_eq AS_ARG_MODE::once_mode
end;
end;
p := p.next -- AS_ARG_DEC::next
end;
exit;-- PARSER::exit
return res
end;
class_def: AS_CLASS_DEF is
-- class =>
-- ['spread' | 'value' | 'partial' | 'external (C | FORTAN)']
-- 'class' uppercase_ident
-- ['{' param_dec {',' param_dec}'}']
-- ['<' type_spec_list]
-- 'is' class_elt_list 'end'
--
enter("class");-- PARSER::enter
res ::= #AS_CLASS_DEF; res.source := source_loc;-- AS_CLASS_DEF::create AS_CLASS_DEF::source PARSER::source_loc
case next.val-- PARSER::next TOKEN::val
when spread_tok then fetch; res.kind := res.spr; match(class_tok);-- PARSER::spread_tok PARSER::fetch AS_CLASS_DEF::kind AS_CLASS_DEF::spr PARSER::class_tok
when immutable_tok then -- PARSER::immutable_tok
fetch; -- PARSER::fetch
res.kind := res.imm; -- AS_CLASS_DEF::kind AS_CLASS_DEF::imm
match(class_tok);-- PARSER::class_tok
when value_tok then -- PARSER::value_tok
if version_1_0 then-- PARSER::version_1_0
fetch; -- PARSER::fetch
res.kind := res.imm; -- AS_CLASS_DEF::kind AS_CLASS_DEF::imm
convert.convert_value;-- PARSER::convert CONVERT::convert_value
match(class_tok); -- PARSER::class_tok
else
error("keyword ``value'' is replaced with ``immutable'' in Sather 1.1. Please use -V1.0 or convert the source using -convert");-- PARSER::error
end;
when partial_tok then fetch; res.kind := res.part; match(class_tok);-- PARSER::partial_tok PARSER::fetch AS_CLASS_DEF::kind AS_CLASS_DEF::part PARSER::class_tok
when external_tok then fetch; -- PARSER::external_tok PARSER::fetch
if check(ident_tok) then-- PARSER::ident_tok
if ident.str = "FORTRAN" then-- PARSER::ident IDENT::str STR::is_eq
res.kind := res.fortran_ext;-- AS_CLASS_DEF::kind AS_CLASS_DEF::fortran_ext
match(class_tok);-- PARSER::class_tok
end;
elsif check(ident_tok) then-- PARSER::ident_tok
if ident.str = "C" then-- PARSER::ident IDENT::str STR::is_eq
res.kind := res.c_ext;-- AS_CLASS_DEF::kind AS_CLASS_DEF::c_ext
match(class_tok);-- PARSER::class_tok
end;
elsif check(class_tok) then -- to preserve compatibility with pre 1.1-- PARSER::class_tok
res.kind := res.c_ext; -- C by default-- AS_CLASS_DEF::kind AS_CLASS_DEF::c_ext
else
exp_error("extern class name");-- PARSER::exp_error
end;
else
res.kind := res.ref;-- AS_CLASS_DEF::kind AS_CLASS_DEF::ref
match(class_tok);-- PARSER::class_tok
end;
if check(ident_tok) then-- PARSER::ident_tok
if ~is_class_name(ident) then-- PARSER::ident BOOL::not
exp_error("class name")-- PARSER::exp_error
end
else exp_error("concrete class name");-- PARSER::exp_error
if next = type_name_tok then fetch end-- PARSER::next PARSER::type_name_tok PARSER::fetch
end;
res.name := ident;-- AS_CLASS_DEF::name PARSER::ident
if check(lbrace_tok) then-- PARSER::lbrace_tok
loop until!(next /= ident_tok);-- PARSER::next PARSER::ident_tok BOOL::not
if void(res.params) then res.params:=param_dec-- AS_CLASS_DEF::params AS_CLASS_DEF::params PARSER::param_dec
else res.params.append(param_dec) end;-- AS_CLASS_DEF::params AS_PARAM_DEC::append PARSER::param_dec
if ~check(comma_tok) then break! end end;-- PARSER::comma_tok BOOL::not
match(rbrace_tok) end;-- PARSER::rbrace_tok
if check(is_lt_tok) then res.under := type_spec_list end;-- PARSER::is_lt_tok AS_CLASS_DEF::under PARSER::type_spec_list
match(is_tok);-- PARSER::is_tok
res.body := class_elt_list;-- AS_CLASS_DEF::body PARSER::class_elt_list
match(end_tok);-- PARSER::end_tok
exit;-- PARSER::exit
return res
end;
is_class_name (x: IDENT): BOOL is
return scanner.is_class_name(x.str)-- PARSER::scanner SCANNER::is_class_name IDENT::str
end;
param_dec: AS_PARAM_DEC is
-- param_dec => uppercase_ident ['<' type_spec]
--
enter("parameter declaration");-- PARSER::enter
res ::= #AS_PARAM_DEC; res.source := source_loc;-- AS_PARAM_DEC::create AS_PARAM_DEC::source PARSER::source_loc
match(ident_tok); res.name := ident;-- PARSER::ident_tok AS_PARAM_DEC::name PARSER::ident
if ~is_class_name(res.name) then -- PARSER::is_class_name AS_PARAM_DEC::name BOOL::not
exp_error("class name") end;-- PARSER::exp_error
if check(is_lt_tok) then res.type_constraint := type_spec end;-- PARSER::is_lt_tok AS_PARAM_DEC::type_constraint PARSER::type_spec
exit;-- PARSER::exit
return res
end;
is_class_elt_start (t: TOKEN): BOOL is
case t.val-- TOKEN::val
when private_tok, readonly_tok, const_tok, shared_tok, stub_tok,-- PARSER::private_tok PARSER::readonly_tok PARSER::const_tok PARSER::shared_tok PARSER::stub_tok
attr_tok, include_tok, ident_tok, bang_tok, iter_bang_tok-- PARSER::attr_tok PARSER::include_tok PARSER::ident_tok PARSER::bang_tok PARSER::iter_bang_tok
then return true
else return false
end
end;
class_elt_list: $AS_CLASS_ELT is
-- class_elt_list => [class_elt] {';' [class_elt]}
--
res: $AS_CLASS_ELT;
enter("list of class elements");-- PARSER::enter
loop
if is_class_elt_start(next) then-- PARSER::next
if void(res) then res := class_elt-- PARSER::class_elt
else res.append(class_elt) end end;-- PARSER::class_elt
if check(semi_tok) then -- ok-- PARSER::semi_tok
elsif is_class_elt_start(next) then exp_error("semicolon")-- PARSER::next PARSER::exp_error
else break! end end;
if next /= end_tok then-- PARSER::next PARSER::end_tok BOOL::not
exp_error("semicolon");-- PARSER::exp_error
loop while!((next /= end_tok) and (next /= eof_tok)); fetch end end;-- PARSER::next PARSER::end_tok BOOL::not PARSER::next PARSER::eof_tok BOOL::not PARSER::fetch
exit;-- PARSER::exit
return res
end;
class_elt: $AS_CLASS_ELT is
-- class_elt => include_clause | const_def | shared_def | attr_def |
-- rout_def | iter_def | stub_def
--
res: $AS_CLASS_ELT;
enter("class element");-- PARSER::enter
mode ::= #TOKEN(null_tok);-- TOKEN::create PARSER::null_tok
if (next = private_tok) or (next = readonly_tok) then mode := next; fetch end;-- PARSER::next PARSER::private_tok PARSER::next PARSER::readonly_tok PARSER::next PARSER::fetch
case next.val-- PARSER::next TOKEN::val
when include_tok then res := include_clause(mode)-- PARSER::include_tok PARSER::include_clause
when const_tok then res := const_def(mode)-- PARSER::const_tok PARSER::const_def
when shared_tok then res := shared_def(mode)-- PARSER::shared_tok PARSER::shared_def
when attr_tok then res := attr_def(mode)-- PARSER::attr_tok PARSER::attr_def
when stub_tok then res := stub_def(mode)-- PARSER::stub_tok PARSER::stub_def
else res := rout_def(mode)-- PARSER::rout_def
end;
exit;-- PARSER::exit
return res
end;
include_clause (mode: TOKEN): $AS_CLASS_ELT is
-- include_clause => 'include' type_spec [feat_mod {',' feat_mod}]
-- feat_mod => ident '->' [['private' | 'readonly'] ident]
--
-- 'private' already seen and stripped if present.
--
res: $AS_CLASS_ELT;
enter("include clause");-- PARSER::enter
if mode = readonly_tok then -- PARSER::readonly_tok
error("readonly not allowed for includes") end;-- PARSER::error
match(include_tok);-- PARSER::include_tok
incl ::= #AS_INCLUDE_CLAUSE; incl.source := source_loc;-- AS_INCLUDE_CLAUSE::create AS_INCLUDE_CLAUSE::source PARSER::source_loc
incl.is_private := mode = private_tok;-- AS_INCLUDE_CLAUSE::is_private PARSER::private_tok
incl.tp := type_spec;-- AS_INCLUDE_CLAUSE::tp PARSER::type_spec
res := incl;
if (next = ident_tok) or (next = bang_tok) or (next = iter_bang_tok) then-- PARSER::next PARSER::ident_tok PARSER::next PARSER::bang_tok PARSER::next PARSER::iter_bang_tok
loop
newm ::= #AS_FEAT_MOD; newm.source := source_loc;-- AS_FEAT_MOD::create AS_FEAT_MOD::source PARSER::source_loc
newm.name := rout_or_iter_name;-- AS_FEAT_MOD::name PARSER::rout_or_iter_name
match(transform_tok);-- PARSER::transform_tok
case next.val-- PARSER::next TOKEN::val
when private_tok then fetch;-- PARSER::private_tok PARSER::fetch
newm.is_private := true;-- AS_FEAT_MOD::is_private
newm.new_name := rout_or_iter_name-- AS_FEAT_MOD::new_name PARSER::rout_or_iter_name
when readonly_tok then fetch;-- PARSER::readonly_tok PARSER::fetch
newm.is_readonly := true;-- AS_FEAT_MOD::is_readonly
newm.new_name := rout_or_iter_name-- AS_FEAT_MOD::new_name PARSER::rout_or_iter_name
when ident_tok, bang_tok, iter_bang_tok then -- PARSER::ident_tok PARSER::bang_tok PARSER::iter_bang_tok
newm.new_name := rout_or_iter_name-- AS_FEAT_MOD::new_name PARSER::rout_or_iter_name
else end;
if ~void(newm.new_name) then-- AS_FEAT_MOD::new_name BOOL::not
if newm.name.is_iter /= newm.new_name.is_iter then-- AS_FEAT_MOD::name IDENT::is_iter BOOL::is_eq AS_FEAT_MOD::new_name IDENT::is_iter BOOL::not
error("routine can't become an iter or vice versa")-- PARSER::error
end
end;
if void(incl.mods) then incl.mods:=newm-- AS_INCLUDE_CLAUSE::mods AS_INCLUDE_CLAUSE::mods
else incl.mods.append(newm) end;-- AS_INCLUDE_CLAUSE::mods AS_FEAT_MOD::append
while!(check(comma_tok))-- PARSER::comma_tok
end
end;
exit;-- PARSER::exit
return res
end;
const_def (mode: TOKEN): $AS_CLASS_ELT is
-- const_def =>
-- ['private'] 'const' ident
-- (':' type_spec ' := ' expr | [' := ' expr][',' ident_list])
--
-- private_tok already seen and stripped if present.
--
res: $AS_CLASS_ELT;
enter("const definition");-- PARSER::enter
if mode = readonly_tok then -- PARSER::readonly_tok
error("readonly not allowed for constants") end;-- PARSER::error
match(const_tok);-- PARSER::const_tok
con ::= #AS_CONST_DEF; con.source := source_loc;-- AS_CONST_DEF::create AS_CONST_DEF::source PARSER::source_loc
con.is_private := mode = private_tok;-- AS_CONST_DEF::is_private PARSER::private_tok
res := con;
match(ident_tok);-- PARSER::ident_tok
con.name := ident;-- AS_CONST_DEF::name PARSER::ident
if check(colon_tok) then-- PARSER::colon_tok
con.tp := type_spec; match(assign_tok); con.init := expr-- AS_CONST_DEF::tp PARSER::type_spec PARSER::assign_tok AS_CONST_DEF::init PARSER::expr
else
if check(assign_tok) then con.init := expr-- PARSER::assign_tok AS_CONST_DEF::init PARSER::expr
else zero ::= #AS_INT_LIT_EXPR; zero.source := source_loc; zero.val := #INTI(0); -- AS_INT_LIT_EXPR::create AS_INT_LIT_EXPR::source PARSER::source_loc AS_INT_LIT_EXPR::val INTI::create
con.init := zero-- AS_CONST_DEF::init
end;
counter: INT := 1;
loop while!(check(comma_tok));-- PARSER::comma_tok
-- new constant
newc ::= #AS_CONST_DEF; newc.source := source_loc;-- AS_CONST_DEF::create AS_CONST_DEF::source PARSER::source_loc
newc.is_private := mode = private_tok;-- AS_CONST_DEF::is_private PARSER::private_tok
match(ident_tok);-- PARSER::ident_tok
newc.name := ident;-- AS_CONST_DEF::name PARSER::ident
-- new value
arg ::= #AS_INT_LIT_EXPR; arg.source := source_loc; arg.val := #INTI(counter);-- AS_INT_LIT_EXPR::create AS_INT_LIT_EXPR::source PARSER::source_loc AS_INT_LIT_EXPR::val INTI::create
ex ::= #AS_CALL_EXPR; ex.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
ex.ob := con.init;-- AS_CALL_EXPR::ob AS_CONST_DEF::init
ex.name := IDENT_BUILTIN::plus_ident;-- AS_CALL_EXPR::name IDENT_BUILTIN::plus_ident
ex.args := arg;-- AS_CALL_EXPR::args
ex.modes := #AS_ARG_MODE(AS_ARG_MODE::in_mode); -- AS_CALL_EXPR::modes AS_ARG_MODE::create AS_ARG_MODE::in_mode
newc.init := ex;-- AS_CONST_DEF::init
if void(res) then res:=newc
else res.append(newc) end;
counter := counter+1-- INT::plus
end
end;
exit;-- PARSER::exit
return res
end;
shared_def (mode: TOKEN): $AS_CLASS_ELT is
-- shared_def =>
-- 'shared' (ident ':' type_spec ':=' expr |
-- ident_list ':' type_spec)
--
-- private or readonly already stripped if present.
--
res: $AS_CLASS_ELT;
enter("shared definition");-- PARSER::enter
match(shared_tok);-- PARSER::shared_tok
loop
newid ::= #AS_SHARED_DEF; newid.source := source_loc;-- AS_SHARED_DEF::create AS_SHARED_DEF::source PARSER::source_loc
newid.is_private := mode = private_tok;-- AS_SHARED_DEF::is_private PARSER::private_tok
newid.is_readonly := mode = readonly_tok;-- AS_SHARED_DEF::is_readonly PARSER::readonly_tok
match(ident_tok);-- PARSER::ident_tok
newid.name := ident;-- AS_SHARED_DEF::name PARSER::ident
if void(res) then res := newid
else res.append(newid)
end;
while!(check(comma_tok)) end;-- PARSER::comma_tok
match(colon_tok);-- PARSER::colon_tok
tp: AS_TYPE_SPEC := type_spec;-- PARSER::type_spec
p: $AS_CLASS_ELT := res;
loop until!(void(p));
typecase p when AS_SHARED_DEF then p.tp := tp end;-- AS_SHARED_DEF::tp
p := p.next
end;
if check(assign_tok) then-- PARSER::assign_tok
typecase res when AS_SHARED_DEF then res.init := expr end;-- AS_SHARED_DEF::init PARSER::expr
if ~void(res.next) then-- BOOL::not
error("only single shareds may be initialized") end end;-- PARSER::error
exit;-- PARSER::exit
return res
end;
attr_def (mode: TOKEN): $AS_CLASS_ELT is
-- attr_def => 'attr' ident_list ':' type_spec
--
-- private or readonly already stripped if present.
--
res: $AS_CLASS_ELT;
enter("attribute definition");-- PARSER::enter
match(attr_tok);-- PARSER::attr_tok
loop
newid ::= #AS_ATTR_DEF; newid.source := source_loc;-- AS_ATTR_DEF::create AS_ATTR_DEF::source PARSER::source_loc
newid.is_private := mode = private_tok;-- AS_ATTR_DEF::is_private PARSER::private_tok
newid.is_readonly := mode = readonly_tok;-- AS_ATTR_DEF::is_readonly PARSER::readonly_tok
match(ident_tok);-- PARSER::ident_tok
newid.name := ident;-- AS_ATTR_DEF::name PARSER::ident
if void(res) then res := newid
else res.append(newid)
end;
while!(check(comma_tok)) end;-- PARSER::comma_tok
match(colon_tok);-- PARSER::colon_tok
tp:AS_TYPE_SPEC := type_spec;-- PARSER::type_spec
p: $AS_CLASS_ELT := res;
loop until!(void(p));
typecase p when AS_ATTR_DEF then p.tp := tp end;-- AS_ATTR_DEF::tp
p := p.next
end;
exit;-- PARSER::exit
return res
end;
stub_def (mode: TOKEN): $AS_CLASS_ELT is
-- stub_def => abstract_signature
--
res: $AS_CLASS_ELT;
enter("stub feature definition");-- PARSER::enter
if mode = readonly_tok then -- PARSER::readonly_tok
error("readonly not allowed for stubs") end;-- PARSER::error
match(stub_tok);-- PARSER::stub_tok
res := abstract_signature;-- PARSER::abstract_signature
res.is_private := mode = private_tok;-- PARSER::private_tok
exit;-- PARSER::exit
return res;
end;
type_spec: AS_TYPE_SPEC is
-- type_spec =>
-- class_name ['{' type_spec_list '}'] |
-- ('ROUT' | 'ITER') ['{' mode type_spec ['!']
-- {',' mode type_spec } '}'] [':' type_spec] |
-- 'SAME'
--
enter("type specification");-- PARSER::enter
res ::= #AS_TYPE_SPEC; res.source := source_loc;-- AS_TYPE_SPEC::create AS_TYPE_SPEC::source PARSER::source_loc
if check(SAME_tok) then res.kind := AS_TYPE_SPEC::same-- PARSER::SAME_tok AS_TYPE_SPEC::kind AS_TYPE_SPEC::same
elsif (next = type_name_tok) or (next = ident_tok) then-- PARSER::next PARSER::type_name_tok PARSER::next PARSER::ident_tok
if (next = ident_tok) and ~is_class_name(ident) then-- PARSER::next PARSER::ident_tok PARSER::ident BOOL::not
error("class name must be all upper_case") end;-- PARSER::error
res.kind := AS_TYPE_SPEC::ord;-- AS_TYPE_SPEC::kind AS_TYPE_SPEC::ord
res.name := ident; fetch;-- AS_TYPE_SPEC::name PARSER::ident PARSER::fetch
if check(lbrace_tok) then-- PARSER::lbrace_tok
res.params := type_spec_list;-- AS_TYPE_SPEC::params PARSER::type_spec_list
match(rbrace_tok) end-- PARSER::rbrace_tok
else
if check(ROUT_tok) then res.kind := AS_TYPE_SPEC::rt-- PARSER::ROUT_tok AS_TYPE_SPEC::kind AS_TYPE_SPEC::rt
elsif check(ITER_tok) then res.kind := AS_TYPE_SPEC::it-- PARSER::ITER_tok AS_TYPE_SPEC::kind AS_TYPE_SPEC::it
else exp_error("type specifier") end;-- PARSER::exp_error
if check(lbrace_tok) then-- PARSER::lbrace_tok
loop
isiter:BOOL := (res.kind = AS_TYPE_SPEC::it);-- AS_TYPE_SPEC::kind INT::is_eq AS_TYPE_SPEC::it
m::= get_mode(isiter);-- PARSER::get_mode
tp:AS_TYPE_SPEC := type_spec;-- PARSER::type_spec
tp.mode := m;-- AS_TYPE_SPEC::mode
if version_1_0 then-- PARSER::version_1_0
if check(bang_tok) or check(iter_bang_tok) then-- PARSER::bang_tok PARSER::iter_bang_tok
if res.kind = AS_TYPE_SPEC::it then tp.is_hot := true-- AS_TYPE_SPEC::kind INT::is_eq AS_TYPE_SPEC::it AS_TYPE_SPEC::is_hot
else error("no hot arguments in bound routine") end end;-- PARSER::error
else
tp.is_hot := (tp.mode.mod /= AS_ARG_MODE::once_mode);-- AS_TYPE_SPEC::is_hot AS_TYPE_SPEC::mode AS_ARG_MODE::mod INT::is_eq AS_ARG_MODE::once_mode BOOL::not
end;
if void(res.params) then res.params:=tp-- AS_TYPE_SPEC::params AS_TYPE_SPEC::params
else res.params.append(tp) end;-- AS_TYPE_SPEC::params AS_TYPE_SPEC::append
while!(check(comma_tok)) end;-- PARSER::comma_tok
match(rbrace_tok) end;-- PARSER::rbrace_tok
if check(colon_tok) then res.ret := type_spec end end;-- PARSER::colon_tok AS_TYPE_SPEC::ret PARSER::type_spec
exit;-- PARSER::exit
return res
end;
type_spec_list: AS_TYPE_SPEC is
-- type_spec_list => type_spec {',' type_spec}
--
enter("list of type specifications");-- PARSER::enter
res ::= type_spec;-- PARSER::type_spec
loop while!(next = comma_tok);-- PARSER::next PARSER::comma_tok
fetch; res.append(type_spec)-- PARSER::fetch AS_TYPE_SPEC::append PARSER::type_spec
end;
exit;-- PARSER::exit
return res
end;
rout_or_iter_name: IDENT is
-- rout_or_iter_name => ident | [ident] '!'
--
res: IDENT;
if next = ident_tok then res := ident; fetch;-- PARSER::next PARSER::ident_tok PARSER::ident PARSER::fetch
if next = iter_bang_tok then fetch;-- PARSER::next PARSER::iter_bang_tok PARSER::fetch
res := append_bang(res)-- PARSER::append_bang
elsif next = bang_tok then fetch;-- PARSER::next PARSER::bang_tok PARSER::fetch
res := append_bang(res); error("not a correct iter_name")-- PARSER::append_bang PARSER::error
end
elsif (next = bang_tok) or (next = iter_bang_tok) then fetch;-- PARSER::next PARSER::bang_tok PARSER::next PARSER::iter_bang_tok PARSER::fetch
res := IDENT_BUILTIN::bang_ident;-- IDENT_BUILTIN::bang_ident
else exp_error("routine or iter name"); res := #IDENT("a")-- PARSER::exp_error IDENT::create
end;
return res
end;
rout_def (mode: TOKEN): AS_ROUT_DEF is
-- rout_def =>
-- (ident | iter_name) ['(' arg_dec {',' arg_dec} ')']
-- [':' type_spec]
-- ['pre' expr] ['post' expr]
-- ['is' (stmt_list | builtin ident [;]) 'end']
--
-- private already stripped if present.
--
res: AS_ROUT_DEF;
enter("routine or iter definition");-- PARSER::enter
if mode = readonly_tok then -- PARSER::readonly_tok
error("readonly not allowed for routines or iters") end;-- PARSER::error
res := #AS_ROUT_DEF; res.source := source_loc;-- AS_ROUT_DEF::create AS_ROUT_DEF::source PARSER::source_loc
res.name := rout_or_iter_name;-- AS_ROUT_DEF::name PARSER::rout_or_iter_name
res.is_private := mode = private_tok;-- AS_ROUT_DEF::is_private PARSER::private_tok
if check(lparen_tok) then-- PARSER::lparen_tok
enter("arguments");-- PARSER::enter
if res.name.is_iter then-- AS_ROUT_DEF::name IDENT::is_iter
convert.convert_iter_def(res.name);-- PARSER::convert CONVERT::convert_iter_def AS_ROUT_DEF::name
end;
loop
if void(res.args_dec) then -- AS_ROUT_DEF::args_dec
res.args_dec:=arg_dec(res.name.is_iter)-- AS_ROUT_DEF::args_dec PARSER::arg_dec AS_ROUT_DEF::name IDENT::is_iter
else res.args_dec.append(arg_dec(res.name.is_iter)) end;-- AS_ROUT_DEF::args_dec AS_ARG_DEC::append PARSER::arg_dec AS_ROUT_DEF::name IDENT::is_iter
while!(check(comma_tok)) end;-- PARSER::comma_tok
if res.name.is_iter then-- AS_ROUT_DEF::name IDENT::is_iter
convert.set_start;-- PARSER::convert CONVERT::set_start
end;
match(rparen_tok);-- PARSER::rparen_tok
exit -- PARSER::exit
end;
if check(colon_tok) then -- PARSER::colon_tok
enter("return type specification");-- PARSER::enter
res.ret_dec := type_spec; -- AS_ROUT_DEF::ret_dec PARSER::type_spec
exit end;-- PARSER::exit
if check(pre_tok) then -- PARSER::pre_tok
enter("precondition declaration");-- PARSER::enter
res.pre_e := expr; -- AS_ROUT_DEF::pre_e PARSER::expr
exit end;-- PARSER::exit
if check(post_tok) then -- PARSER::post_tok
enter("postcondition declaration");-- PARSER::enter
res.post_e := expr; -- AS_ROUT_DEF::post_e PARSER::expr
exit end;-- PARSER::exit
if check(is_tok) then-- PARSER::is_tok
if check(builtin_tok) then-- PARSER::builtin_tok
enter("builtin routine/iter body");-- PARSER::enter
res.is_builtin:=true;-- AS_ROUT_DEF::is_builtin
res.builtin_name:=ident;-- AS_ROUT_DEF::builtin_name PARSER::ident
match(ident_tok);-- PARSER::ident_tok
if check(semi_tok) then end;-- PARSER::semi_tok
match(end_tok);-- PARSER::end_tok
exit;-- PARSER::exit
else
enter("routine/iter body");-- PARSER::enter
res.body := stmt_list; res.is_abstract := false;-- AS_ROUT_DEF::body PARSER::stmt_list AS_ROUT_DEF::is_abstract
match(end_tok);-- PARSER::end_tok
exit-- PARSER::exit
end;
else res.is_abstract:=true end;-- AS_ROUT_DEF::is_abstract
exit;-- PARSER::exit
return res
end;
arg_dec (is_iter: BOOL): AS_ARG_DEC is
-- arg_dec => mode ident {',' ident} ':' type_spec
--
res: AS_ARG_DEC;
mode: AS_ARG_MODE;
enter("routine/iter argument declaration");-- PARSER::enter
loop
newa ::= #AS_ARG_DEC; newa.source := source_loc;-- AS_ARG_DEC::create AS_ARG_DEC::source PARSER::source_loc
mode := get_mode(is_iter);-- PARSER::get_mode
match(ident_tok);-- PARSER::ident_tok
newa.name := ident;-- AS_ARG_DEC::name PARSER::ident
newa.mode := mode;-- AS_ARG_DEC::mode
if (newa.mode.mod = AS_ARG_MODE::once_mode) and ~is_iter then-- AS_ARG_DEC::mode AS_ARG_MODE::mod INT::is_eq AS_ARG_MODE::once_mode BOOL::not
error("once arguments not allowed in routine declarations");-- PARSER::error
end;
if void(res) then res:=newa
else res.append(newa) end;-- AS_ARG_DEC::append
while!(check(comma_tok)) -- PARSER::comma_tok
end;
match(colon_tok);-- PARSER::colon_tok
tp:AS_TYPE_SPEC := type_spec;-- PARSER::type_spec
hot:BOOL;
if version_1_0 then-- PARSER::version_1_0
hot := check(bang_tok) or check(iter_bang_tok);-- PARSER::bang_tok PARSER::iter_bang_tok
if hot and ~is_iter then-- BOOL::not
error("hot arguments not allowed in routine declarations") end;-- PARSER::error
end;
p:AS_ARG_DEC := res;
loop until!(void(p));
p.tp := tp; -- AS_ARG_DEC::tp
if version_1_0 then-- PARSER::version_1_0
p.is_hot := hot; -- AS_ARG_DEC::is_hot
else
if is_iter then
p.is_hot := (p.mode.mod /= AS_ARG_MODE::once_mode)-- AS_ARG_DEC::is_hot AS_ARG_DEC::mode AS_ARG_MODE::mod INT::is_eq AS_ARG_MODE::once_mode
end;
end;
if is_iter then
if ~p.is_hot and p.mode.is_out_inout then-- AS_ARG_DEC::is_hot BOOL::not AS_ARG_DEC::mode AS_ARG_MODE::is_out_inout
error("once arguments cannot have out/inout mode");-- PARSER::error
end;
end;
p := p.next -- AS_ARG_DEC::next
end;
exit;-- PARSER::exit
return res
end;
ident_of (x: $AS_EXPR): IDENT is
-- make sure x consists of an ident only
--
typecase x when AS_CALL_EXPR then
if void(x.ob) and ~void(x.name) and void(x.args) then return x.name end-- AS_CALL_EXPR::ob AS_CALL_EXPR::name BOOL::not AS_CALL_EXPR::args AS_CALL_EXPR::name
else end;
error("identifier only expected");-- PARSER::error
return void
end;
break_stmt:AS_EXPR_STMT is
res ::= #AS_EXPR_STMT; res.source := source_loc; res.e := #AS_BREAK_EXPR;-- AS_EXPR_STMT::create AS_EXPR_STMT::source PARSER::source_loc AS_EXPR_STMT::e AS_BREAK_EXPR::create
return res
end;
make_if_stmt (test: $AS_EXPR, then_part, else_part: $AS_STMT): AS_IF_STMT is
res ::= #AS_IF_STMT; res.source := source_loc; res.test := test; -- AS_IF_STMT::create AS_IF_STMT::source PARSER::source_loc AS_IF_STMT::test
res.then_part := #AS_STMT_LIST;-- AS_IF_STMT::then_part AS_STMT_LIST::create
if ~void(then_part) then-- BOOL::not
then_part.surr_stmt_list := res.then_part;-- AS_IF_STMT::then_part
res.then_part.stmts := then_part;-- AS_IF_STMT::then_part AS_STMT_LIST::stmts
end;
if ~void(else_part) then-- BOOL::not
res.else_part := #AS_STMT_LIST;-- AS_IF_STMT::else_part AS_STMT_LIST::create
else_part.surr_stmt_list := res.else_part;-- AS_IF_STMT::else_part
res.else_part.stmts := else_part;-- AS_IF_STMT::else_part AS_STMT_LIST::stmts
end;
return res
end;
stmt: $AS_STMT is
-- stmt =>
-- dec_stmt | assign_stmt | expr_stmt |
-- if_stmt | loop_stmt | return_stmt | yield_stmt | quit_stmt |
-- case_stmt | typecase_stmt | assert_stmt | protect_stmt | raise_stmt
-- while!_expr | until!_expr | break!_expr |
-- lock_stmt | unlock_stmt | with_near_stmt |
-- par_stmt | parloop_stmt | fork_stmt | sync_stmt
--
-- (while!_expr's and until!_expr's are transformed into aquivalent
-- if statements and break!'s)
--
res: $AS_STMT;
enter("statement");-- PARSER::enter
was_at: SFILE_ID := source_loc;-- PARSER::source_loc
case next.val-- PARSER::next TOKEN::val
when if_tok then fetch; res := if_stmt-- PARSER::if_tok PARSER::fetch PARSER::if_stmt
when loop_tok then res := loop_stmt-- PARSER::loop_tok PARSER::loop_stmt
when return_tok then res := return_stmt-- PARSER::return_tok PARSER::return_stmt
when yield_tok then res := yield_stmt-- PARSER::yield_tok PARSER::yield_stmt
when quit_tok then fetch; res := #AS_QUIT_STMT; res.source := source_loc;-- PARSER::quit_tok PARSER::fetch AS_QUIT_STMT::create PARSER::source_loc
when case_tok then res := case_stmt-- PARSER::case_tok PARSER::case_stmt
when typecase_tok then res := typecase_stmt-- PARSER::typecase_tok PARSER::typecase_stmt
when assert_tok then res := assert_stmt-- PARSER::assert_tok PARSER::assert_stmt
when protect_tok then res := protect_stmt-- PARSER::protect_tok PARSER::protect_stmt
when raise_tok then res := raise_stmt-- PARSER::raise_tok PARSER::raise_stmt
when par_tok then res := par_stmt-- PARSER::par_tok PARSER::par_stmt
when parloop_tok then res := parloop_stmt-- PARSER::parloop_tok PARSER::parloop_stmt
when lock_tok then res := lock_stmt-- PARSER::lock_tok PARSER::lock_stmt
when unlock_tok then res := unlock_stmt-- PARSER::unlock_tok PARSER::unlock_stmt
when with_tok then res := with_near_stmt-- PARSER::with_tok PARSER::with_near_stmt
when fork_tok then res := fork_stmt-- PARSER::fork_tok PARSER::fork_stmt
when sync_tok then res := sync_stmt-- PARSER::sync_tok PARSER::sync_stmt
when while_tok then-- PARSER::while_tok
enter("while! expression");-- PARSER::enter
fetch; match(lparen_tok);-- PARSER::fetch PARSER::lparen_tok
res := make_if_stmt(expr, void, break_stmt);-- PARSER::expr PARSER::break_stmt
match(rparen_tok);-- PARSER::rparen_tok
exit-- PARSER::exit
when until_tok then-- PARSER::until_tok
enter("until! expression");-- PARSER::enter
fetch; match(lparen_tok);-- PARSER::fetch PARSER::lparen_tok
res := make_if_stmt(expr, break_stmt, void);-- PARSER::expr PARSER::break_stmt
match(rparen_tok);-- PARSER::rparen_tok
exit-- PARSER::exit
when break_tok then-- PARSER::break_tok
fetch; res := break_stmt-- PARSER::fetch PARSER::break_stmt
else
-- must be one of:dec_stmt, assign_stmt, fork_stmt (with lhs) or expr_stmt:
--
-- dec_stmt => ident_list ':' type_spec
-- assign_stmt => (expr | ident ':' [type_spec]) ' := ' expr
-- expr_stmt => expr
-- attach_stmt => expr ':-' expr
--
-- none of these can be easily distinguished; all may start
-- with identifiers. However, all look like they start
-- with expr's, so do that and then patch up.
x: $AS_EXPR := expr;-- PARSER::expr
if check(colon_tok) then -- ident ':'-- PARSER::colon_tok
tp: AS_TYPE_SPEC;
if next /= assign_tok then tp := type_spec end;-- PARSER::next PARSER::assign_tok BOOL::not PARSER::type_spec
if check(assign_tok) then -- ident ':' [type_spec] ' := '-- PARSER::assign_tok
enter("assignment with declaration");-- PARSER::enter
r ::= #AS_ASSIGN_STMT; r.source := source_loc;-- AS_ASSIGN_STMT::create AS_ASSIGN_STMT::source PARSER::source_loc
r.name := ident_of(x); r.tp := tp; r.rhs := expr; res := r;-- AS_ASSIGN_STMT::name PARSER::ident_of AS_ASSIGN_STMT::tp AS_ASSIGN_STMT::rhs PARSER::expr
exit-- PARSER::exit
else -- ident ':' type_spec
enter("single variable declaration");-- PARSER::enter
sdecl_res ::= #AS_DEC_STMT; sdecl_res.source := source_loc;-- AS_DEC_STMT::create AS_DEC_STMT::source PARSER::source_loc
sdecl_res.name := ident_of(x);-- AS_DEC_STMT::name PARSER::ident_of
sdecl_res.tp := tp;-- AS_DEC_STMT::tp
res := sdecl_res;
exit-- PARSER::exit
end
elsif check(assign_tok) then -- expr ':='-- PARSER::assign_tok
enter("assignment");-- PARSER::enter
r ::= #AS_ASSIGN_STMT; r.source := source_loc;-- AS_ASSIGN_STMT::create AS_ASSIGN_STMT::source PARSER::source_loc
r.lhs_expr := x; r.rhs := expr; res := r;-- AS_ASSIGN_STMT::lhs_expr AS_ASSIGN_STMT::rhs PARSER::expr
exit-- PARSER::exit
elsif check(attach_tok) then -- expr ':-'-- PARSER::attach_tok
enter("fork statement (with LHS)");-- PARSER::enter
r ::= #AS_ATTACH_STMT; r.source := source_loc;-- AS_ATTACH_STMT::create AS_ATTACH_STMT::source PARSER::source_loc
r.lhs := x; r.rhs := expr; res := r;-- AS_ATTACH_STMT::lhs AS_ATTACH_STMT::rhs PARSER::expr
exit-- PARSER::exit
elsif next = comma_tok then -- ident ','-- PARSER::next PARSER::comma_tok
enter("declaration");-- PARSER::enter
decl_res ::= #AS_DEC_STMT; decl_res.source := source_loc;-- AS_DEC_STMT::create AS_DEC_STMT::source PARSER::source_loc
decl_res.name := ident_of(x);-- AS_DEC_STMT::name PARSER::ident_of
res := decl_res;
loop while!(check(comma_tok));-- PARSER::comma_tok
newdec ::= #AS_DEC_STMT;-- AS_DEC_STMT::create
newdec.source := source_loc;-- AS_DEC_STMT::source PARSER::source_loc
match(ident_tok);-- PARSER::ident_tok
newdec.name := ident;-- AS_DEC_STMT::name PARSER::ident
if void(res) then res := newdec
else res.append(newdec) end
end;
match(colon_tok);-- PARSER::colon_tok
tp2: AS_TYPE_SPEC := type_spec;-- PARSER::type_spec
p: $AS_STMT := decl_res;
loop until!(void(p));
typecase p when AS_DEC_STMT then p.tp := tp2 end;-- AS_DEC_STMT::tp
p := p.next
end;
exit-- PARSER::exit
else -- expr
r ::= #AS_EXPR_STMT; r.source := source_loc;-- AS_EXPR_STMT::create AS_EXPR_STMT::source PARSER::source_loc
r.e := x; res := r-- AS_EXPR_STMT::e
end
end;
res.source := was_at;
exit;-- PARSER::exit
return res
end;
is_expr_start (t:TOKEN):BOOL is
case t.val-- TOKEN::val
when self_tok, ident_tok, bang_tok, iter_bang_tok, SAME_tok, void_tok,-- PARSER::self_tok PARSER::ident_tok PARSER::bang_tok PARSER::iter_bang_tok PARSER::SAME_tok PARSER::void_tok
minus_tok, not_tok, new_tok, sharp_tok, vbar_tok, exception_tok, -- PARSER::minus_tok PARSER::not_tok PARSER::new_tok PARSER::sharp_tok PARSER::vbar_tok PARSER::exception_tok
initial_tok, result_tok, while_tok, until_tok, break_tok, -- PARSER::initial_tok PARSER::result_tok PARSER::while_tok PARSER::until_tok PARSER::break_tok
true_tok, false_tok, lchar_tok, lstr_tok, lint_tok, lflt_tok, -- PARSER::true_tok PARSER::false_tok PARSER::lchar_tok PARSER::lstr_tok PARSER::lint_tok PARSER::lflt_tok
lparen_tok, lbracket_tok,-- PARSER::lparen_tok PARSER::lbracket_tok
-- pSather tokens
here_tok, where_tok, near_tok, far_tok, cluster_tok, -- PARSER::here_tok PARSER::where_tok PARSER::near_tok PARSER::far_tok PARSER::cluster_tok
cluster_bang_tok, cluster_size_tok, cohort_tok-- PARSER::cluster_bang_tok PARSER::cluster_size_tok PARSER::cohort_tok
then return true
else return false
end
end;
is_stmt_start (t:TOKEN):BOOL is
case t.val-- TOKEN::val
when ident_tok, if_tok, loop_tok, yield_tok, quit_tok, return_tok,-- PARSER::ident_tok PARSER::if_tok PARSER::loop_tok PARSER::yield_tok PARSER::quit_tok PARSER::return_tok
case_tok, typecase_tok, assert_tok, protect_tok, raise_tok,-- PARSER::case_tok PARSER::typecase_tok PARSER::assert_tok PARSER::protect_tok PARSER::raise_tok
while_tok, until_tok, break_tok,-- PARSER::while_tok PARSER::until_tok PARSER::break_tok
-- pSather tokens
fork_tok, lock_tok, unlock_tok, with_tok,-- PARSER::fork_tok PARSER::lock_tok PARSER::unlock_tok PARSER::with_tok
par_tok, parloop_tok, cohort_tok, sync_tok-- PARSER::par_tok PARSER::parloop_tok PARSER::cohort_tok PARSER::sync_tok
then return true
else return is_expr_start(t)-- PARSER::is_expr_start
end
end;
stmt_list: AS_STMT_LIST is
-- stmt_list => [stmt] {';' [stmt]}
--
list ::= #AS_STMT_LIST;-- AS_STMT_LIST::create
res : $AS_STMT;
enter("list of statements");-- PARSER::enter
loop
if is_stmt_start(next) then-- PARSER::next
s ::= stmt; s.surr_stmt_list := list; nx::=s.next;-- PARSER::stmt
loop while!(~void(nx)); nx.surr_stmt_list:=list; nx:=nx.next end;-- BOOL::not
if void(res) then res := s
else res.append(s) end end;
if check(semi_tok) then -- ok-- PARSER::semi_tok
elsif is_stmt_start(next) then exp_error("semicolon")-- PARSER::next PARSER::exp_error
else break! end end;
exit;-- PARSER::exit
list.stmts := res;-- AS_STMT_LIST::stmts
return list;
end;
if_stmt: AS_IF_STMT is
-- if_stmt =>
-- 'if' expr 'then' stmt_list {'elsif' expr 'then' stmt_list}
-- ['else' stmt_list] 'end'
--
-- if_tok already fetched
--
enter("if statement");-- PARSER::enter
res ::= #AS_IF_STMT; res.source := source_loc;-- AS_IF_STMT::create AS_IF_STMT::source PARSER::source_loc
res.test := expr; match(then_tok); res.then_part := stmt_list;-- AS_IF_STMT::test PARSER::expr PARSER::then_tok AS_IF_STMT::then_part PARSER::stmt_list
if check(elsif_tok) then -- PARSER::elsif_tok
res.else_part := #AS_STMT_LIST;-- AS_IF_STMT::else_part AS_STMT_LIST::create
ifstmt ::= if_stmt;-- PARSER::if_stmt
ifstmt.surr_stmt_list := res.else_part;-- AS_IF_STMT::surr_stmt_list AS_IF_STMT::else_part
res.else_part.stmts := ifstmt;-- AS_IF_STMT::else_part AS_STMT_LIST::stmts
else
if check(else_tok) then res.else_part := stmt_list end;-- PARSER::else_tok AS_IF_STMT::else_part PARSER::stmt_list
match(end_tok) end;-- PARSER::end_tok
exit;-- PARSER::exit
return res
end;
loop_stmt: AS_LOOP_STMT is
-- loop_stmt => 'loop' stmt_list 'end'
--
enter("loop statement");-- PARSER::enter
match(loop_tok);-- PARSER::loop_tok
res ::= #AS_LOOP_STMT; res.source := source_loc;-- AS_LOOP_STMT::create AS_LOOP_STMT::source PARSER::source_loc
res.body := stmt_list;-- AS_LOOP_STMT::body PARSER::stmt_list
match(end_tok);-- PARSER::end_tok
exit;-- PARSER::exit
return res
end;
case_stmt: AS_CASE_STMT is
-- case_stmt =>
-- 'case' expr
-- {'when' expr {',' expr} ' then' stmt_list}
-- ['else' stmt_list] 'end'
--
enter("case statement");-- PARSER::enter
match(case_tok);-- PARSER::case_tok
res ::= #AS_CASE_STMT; res.source := source_loc;-- AS_CASE_STMT::create AS_CASE_STMT::source PARSER::source_loc
res.test := expr;-- AS_CASE_STMT::test PARSER::expr
loop while!(check(when_tok));-- PARSER::when_tok
first, this:AS_CASE_WHEN;
first := void;
loop
this := #AS_CASE_WHEN; this.source := source_loc;-- AS_CASE_WHEN::create AS_CASE_WHEN::source PARSER::source_loc
if void(first) then first := this end;
this.val := expr;-- AS_CASE_WHEN::val PARSER::expr
if void(res.when_part) then res.when_part:=this-- AS_CASE_STMT::when_part AS_CASE_STMT::when_part
else res.when_part.append(this) end;-- AS_CASE_STMT::when_part AS_CASE_WHEN::append
while!(check(comma_tok)) end;-- PARSER::comma_tok
match(then_tok);-- PARSER::then_tok
st: AS_STMT_LIST := stmt_list; this := first;-- PARSER::stmt_list
loop until!(void(this)); this.then_part := st; -- AS_CASE_WHEN::then_part
this := this.next end end;-- AS_CASE_WHEN::next
if check(else_tok) then -- PARSER::else_tok
res.else_part := stmt_list; res.no_else := false-- AS_CASE_STMT::else_part PARSER::stmt_list AS_CASE_STMT::no_else
else res.no_else := true end;-- AS_CASE_STMT::no_else
match(end_tok);-- PARSER::end_tok
exit;-- PARSER::exit
return res
end;
typecase_stmt: AS_TYPECASE_STMT is
-- typecase_stmt =>
-- 'typecase' ident
-- {'when' type_spec 'then' stmt_list}
-- ['else' stmt_list] 'end'
--
enter("typecase statement");-- PARSER::enter
match(typecase_tok);-- PARSER::typecase_tok
res ::= #AS_TYPECASE_STMT; res.source := source_loc;-- AS_TYPECASE_STMT::create AS_TYPECASE_STMT::source PARSER::source_loc
match(ident_tok);-- PARSER::ident_tok
res.name := ident;-- AS_TYPECASE_STMT::name PARSER::ident
loop while!(check(when_tok));-- PARSER::when_tok
this ::= #AS_TYPECASE_WHEN; this.source := source_loc;-- AS_TYPECASE_WHEN::create AS_TYPECASE_WHEN::source PARSER::source_loc
this.tp := type_spec;-- AS_TYPECASE_WHEN::tp PARSER::type_spec
match(then_tok);-- PARSER::then_tok
this.then_part := stmt_list;-- AS_TYPECASE_WHEN::then_part PARSER::stmt_list
if void(res.when_part) then res.when_part:=this-- AS_TYPECASE_STMT::when_part AS_TYPECASE_STMT::when_part
else res.when_part.append(this) end end;-- AS_TYPECASE_STMT::when_part AS_TYPECASE_WHEN::append
if check(else_tok) then -- PARSER::else_tok
res.else_part := stmt_list; res.no_else := false-- AS_TYPECASE_STMT::else_part PARSER::stmt_list AS_TYPECASE_STMT::no_else
else res.no_else := true end;-- AS_TYPECASE_STMT::no_else
match(end_tok);-- PARSER::end_tok
exit;-- PARSER::exit
return res
end;
return_stmt: AS_RETURN_STMT is
-- return_stmt => 'return' [expr]
--
enter("return statement");-- PARSER::enter
res ::= #AS_RETURN_STMT; res.source := source_loc;-- AS_RETURN_STMT::create AS_RETURN_STMT::source PARSER::source_loc
match(return_tok);-- PARSER::return_tok
if is_expr_start(next) then res.val := expr end;-- PARSER::next AS_RETURN_STMT::val PARSER::expr
exit;-- PARSER::exit
return res
end;
yield_stmt: AS_YIELD_STMT is
-- return_stmt => 'yield' [expr]
--
enter("yield statement");-- PARSER::enter
res ::= #AS_YIELD_STMT; res.source := source_loc;-- AS_YIELD_STMT::create AS_YIELD_STMT::source PARSER::source_loc
match(yield_tok);-- PARSER::yield_tok
if is_expr_start(next) then res.val := expr end;-- PARSER::next AS_YIELD_STMT::val PARSER::expr
exit;-- PARSER::exit
return res
end;
assert_stmt: AS_ASSERT_STMT is
-- assert_stmt => 'assert' expr 'end'
--
enter("assert statement");-- PARSER::enter
res ::= #AS_ASSERT_STMT; res.source := source_loc;-- AS_ASSERT_STMT::create AS_ASSERT_STMT::source PARSER::source_loc
match(assert_tok);-- PARSER::assert_tok
res.test := expr;-- AS_ASSERT_STMT::test PARSER::expr
exit;-- PARSER::exit
return res
end;
raise_stmt: AS_RAISE_STMT is
-- raise_stmr => 'raise' expr
--
enter("raise statement");-- PARSER::enter
res ::= #AS_RAISE_STMT; res.source := source_loc;-- AS_RAISE_STMT::create AS_RAISE_STMT::source PARSER::source_loc
match(raise_tok);-- PARSER::raise_tok
res.val := expr;-- AS_RAISE_STMT::val PARSER::expr
exit;-- PARSER::exit
return res
end;
protect_stmt: AS_PROTECT_STMT is
-- protect_stmt =>
-- 'protect' stmt_list
-- {'when' type_spec_list 'then' stmt_list}
-- ['else' stmt_list] 'end'
--
enter("protect statement");-- PARSER::enter
match(protect_tok);-- PARSER::protect_tok
res ::= #AS_PROTECT_STMT; res.source := source_loc;-- AS_PROTECT_STMT::create AS_PROTECT_STMT::source PARSER::source_loc
res.body := stmt_list;-- AS_PROTECT_STMT::body PARSER::stmt_list
loop while!(check(when_tok));-- PARSER::when_tok
first, this:AS_PROTECT_WHEN;
first := void;
loop
this := #AS_PROTECT_WHEN; this.source := source_loc;-- AS_PROTECT_WHEN::create AS_PROTECT_WHEN::source PARSER::source_loc
if void(first) then first := this end;
this.tp := type_spec;-- AS_PROTECT_WHEN::tp PARSER::type_spec
if void(res.when_part) then res.when_part:=this-- AS_PROTECT_STMT::when_part AS_PROTECT_STMT::when_part
else res.when_part.append(this) end;-- AS_PROTECT_STMT::when_part AS_PROTECT_WHEN::append
while!(check(comma_tok)) end;-- PARSER::comma_tok
match(then_tok);-- PARSER::then_tok
st: AS_STMT_LIST := stmt_list; this := first;-- PARSER::stmt_list
loop until!(void(this)); this.then_part := st; -- AS_PROTECT_WHEN::then_part
this := this.next end end;-- AS_PROTECT_WHEN::next
if check(else_tok) then -- PARSER::else_tok
res.else_part := stmt_list; res.no_else := false-- AS_PROTECT_STMT::else_part PARSER::stmt_list AS_PROTECT_STMT::no_else
else res.no_else := true end;-- AS_PROTECT_STMT::no_else
match(end_tok);-- PARSER::end_tok
exit;-- PARSER::exit
return res
end;
par_stmt: AS_PAR_STMT is
-- par_stmt => 'par' stmt_list 'end'
-- (pSather construct)
--
enter("par statement");-- PARSER::enter
match(par_tok);-- PARSER::par_tok
res ::= #AS_PAR_STMT; res.source := source_loc;-- AS_PAR_STMT::create AS_PAR_STMT::source PARSER::source_loc
res.body := stmt_list;-- AS_PAR_STMT::body PARSER::stmt_list
match(end_tok);-- PARSER::end_tok
exit;-- PARSER::exit
return res
end;
parloop_stmt: AS_PAR_STMT is
-- parloop_stmt => 'parloop' stmt_list 'do' stmt_list 'end'
-- (pSather construct)
enter("parloop statement");-- PARSER::enter
match(parloop_tok);-- PARSER::parloop_tok
res ::= #AS_PAR_STMT; res.source := source_loc;-- AS_PAR_STMT::create AS_PAR_STMT::source PARSER::source_loc
lp ::= #AS_LOOP_STMT; lp.source := source_loc;-- AS_LOOP_STMT::create AS_LOOP_STMT::source PARSER::source_loc
res.body := #AS_STMT_LIST;-- AS_PAR_STMT::body AS_STMT_LIST::create
lp.surr_stmt_list := res.body;-- AS_LOOP_STMT::surr_stmt_list AS_PAR_STMT::body
res.body.stmts := lp;-- AS_PAR_STMT::body AS_STMT_LIST::stmts
lp.body := stmt_list;-- AS_LOOP_STMT::body PARSER::stmt_list
match(do_tok);-- PARSER::do_tok
forkt ::= #AS_FORK_STMT;-- AS_FORK_STMT::create
forkt.surr_stmt_list := lp.body;-- AS_FORK_STMT::surr_stmt_list AS_LOOP_STMT::body
forkt.source := source_loc;-- AS_FORK_STMT::source PARSER::source_loc
-- optional at expression
if check(at_tok) then-- PARSER::at_tok
forkt.at := expr;-- AS_FORK_STMT::at PARSER::expr
-- match(semi_tok);
-- else
-- forkt.at := #AS_ANY_EXPR; -- default;
end;
forkt.body := stmt_list;-- AS_FORK_STMT::body PARSER::stmt_list
match(end_tok);-- PARSER::end_tok
if void(lp.body.stmts) then -- AS_LOOP_STMT::body AS_STMT_LIST::stmts
lp.body.stmts := forkt;-- AS_LOOP_STMT::body AS_STMT_LIST::stmts
else
lp.body.stmts.append(forkt);-- AS_LOOP_STMT::body AS_STMT_LIST::stmts
end;
exit;-- PARSER::exit
return res
end;
fork_stmt: AS_FORK_STMT is
-- fork_stmt => 'fork' ['@' expr;] stmt_list 'end'
-- (pSather construct)
--
enter("fork statement");-- PARSER::enter
match(fork_tok);-- PARSER::fork_tok
res ::= #AS_FORK_STMT; res.source := source_loc;-- AS_FORK_STMT::create AS_FORK_STMT::source PARSER::source_loc
-- optional at expression
if check(at_tok) then-- PARSER::at_tok
res.at := expr;-- AS_FORK_STMT::at PARSER::expr
-- match(semi_tok);
-- else
-- res.at := #AS_ANY_EXPR; -- default;
end;
res.body := stmt_list;-- AS_FORK_STMT::body PARSER::stmt_list
match(end_tok);-- PARSER::end_tok
exit;-- PARSER::exit
return res
end;
sync_stmt: AS_SYNC_STMT is
-- sync_stmt => 'sync'
-- (pSather construct)
--
enter("sync statement");-- PARSER::enter
match(sync_tok);-- PARSER::sync_tok
res ::= #AS_SYNC_STMT; res.source := source_loc;-- AS_SYNC_STMT::create AS_SYNC_STMT::source PARSER::source_loc
exit;-- PARSER::exit
return res
end;
lock_stmt: AS_LOCK_STMT is
-- lock_stmt => 'lock'
-- { ['if' expr] 'when' expr {',' expr} 'then' stmt_list }
-- [ 'else' stmt_list] 'end'
-- (pSather construct)
--
enter("lock statement");-- PARSER::enter
res ::= #AS_LOCK_STMT; res.source := source_loc;-- AS_LOCK_STMT::create AS_LOCK_STMT::source PARSER::source_loc
match(lock_tok);-- PARSER::lock_tok
with_guard : BOOL;
with_guard := false;
if check(guard_tok) then with_guard := true end;-- PARSER::guard_tok
only_one::=false;
if ~with_guard then -- BOOL::not
if ~check(when_tok) then -- PARSER::when_tok BOOL::not
only_one:=true;
end;
end;
loop
this ::= #AS_LOCK_IF_WHEN; this.source := source_loc;-- AS_LOCK_IF_WHEN::create AS_LOCK_IF_WHEN::source PARSER::source_loc
if with_guard then this.val := expr-- AS_LOCK_IF_WHEN::val PARSER::expr
else r::= #AS_BOOL_LIT_EXPR; r.val := true; this.val := r end;-- AS_BOOL_LIT_EXPR::create AS_BOOL_LIT_EXPR::val AS_LOCK_IF_WHEN::val
if void(res.if_when_part) then res.if_when_part := this-- AS_LOCK_STMT::if_when_part AS_LOCK_STMT::if_when_part
else res.if_when_part.append(this) end;-- AS_LOCK_STMT::if_when_part AS_LOCK_IF_WHEN::append
if with_guard then match(when_tok) end;-- PARSER::when_tok
this.e_list := expr_list(false);-- AS_LOCK_IF_WHEN::e_list PARSER::expr_list
match(then_tok);-- PARSER::then_tok
this.then_part := stmt_list;-- AS_LOCK_IF_WHEN::then_part PARSER::stmt_list
-- match(end_tok);
with_guard := false;
if check(guard_tok) then with_guard := true end;-- PARSER::guard_tok
if only_one or ~(with_guard or check(when_tok)) then break! end; -- PARSER::when_tok BOOL::not
end;
if check(else_tok) then-- PARSER::else_tok
res.else_part := stmt_list; res.no_else := false-- AS_LOCK_STMT::else_part PARSER::stmt_list AS_LOCK_STMT::no_else
else res.no_else := true end;-- AS_LOCK_STMT::no_else
match(end_tok);-- PARSER::end_tok
exit;-- PARSER::exit
return res
end;
unlock_stmt: AS_UNLOCK_STMT is
-- unlock_stmt => 'unlock' expr
-- (pSather construct)
--
enter("unlock statement");-- PARSER::enter
res ::= #AS_UNLOCK_STMT; res.source := source_loc;-- AS_UNLOCK_STMT::create AS_UNLOCK_STMT::source PARSER::source_loc
match(unlock_tok); res.e := expr;-- PARSER::unlock_tok AS_UNLOCK_STMT::e PARSER::expr
exit;-- PARSER::exit
return res
end;
ident_list(t:$AS_NODE): AS_IDENT_LIST is
-- ident_list => ident {',' ident}
-- in pSather with-near-mode `self' is allowed. The occurence of
-- 'self' is marked in t
--
enter("identifier list");-- PARSER::enter
res, id: AS_IDENT_LIST;
loop
if next = ident_tok then-- PARSER::next PARSER::ident_tok
id := #AS_IDENT_LIST; id.name := ident; id.source := source_loc;-- AS_IDENT_LIST::create AS_IDENT_LIST::name PARSER::ident AS_IDENT_LIST::source PARSER::source_loc
elsif next = self_tok then-- PARSER::next PARSER::self_tok
typecase t
when AS_WITH_NEAR_STMT then
t.self_occurred := true;-- AS_WITH_NEAR_STMT::self_occurred
else
exp_error("identifier");-- PARSER::exp_error
end;
else exp_error("identifier")-- PARSER::exp_error
end;
if next = ident_tok then-- PARSER::next PARSER::ident_tok
fetch;-- PARSER::fetch
if void(res) then res := id
else res.append(id)-- AS_IDENT_LIST::append
end;
else
fetch;-- PARSER::fetch
end;
while!(check(comma_tok))-- PARSER::comma_tok
end;
exit;-- PARSER::exit
return res
end;
with_near_stmt: AS_WITH_NEAR_STMT is
-- with_near_stmt =>
-- 'with' ident_list 'near' stmt_list
-- ['else' stmt_list] 'end'
-- (pSather construct)
--
enter("with_near statement");-- PARSER::enter
res ::= #AS_WITH_NEAR_STMT; res.source := source_loc;-- AS_WITH_NEAR_STMT::create AS_WITH_NEAR_STMT::source PARSER::source_loc
match(with_tok); res.idents := ident_list(res);-- PARSER::with_tok AS_WITH_NEAR_STMT::idents PARSER::ident_list
-- count elements of ident list
res.elts_size := 0;-- AS_WITH_NEAR_STMT::elts_size
id ::= res.idents;-- AS_WITH_NEAR_STMT::idents
loop while!(~void(id)); -- BOOL::not
res.elts_size := res.elts_size + 1; -- AS_WITH_NEAR_STMT::elts_size AS_WITH_NEAR_STMT::elts_size INT::plus
id := id.next;-- AS_IDENT_LIST::next
end;
if res.self_occurred then-- AS_WITH_NEAR_STMT::self_occurred
res.elts_size := res.elts_size + 1;-- AS_WITH_NEAR_STMT::elts_size AS_WITH_NEAR_STMT::elts_size INT::plus
end;
match(near_tok); res.near_part := stmt_list;-- PARSER::near_tok AS_WITH_NEAR_STMT::near_part PARSER::stmt_list
if check(else_tok) then res.else_part := stmt_list end;-- PARSER::else_tok AS_WITH_NEAR_STMT::else_part PARSER::stmt_list
match(end_tok);-- PARSER::end_tok
exit;-- PARSER::exit
return res
end;
expr: $AS_EXPR is
-- expr => expr7 {'@' [expr 7 | any]}
--
enter("expression (prec = 8)");-- PARSER::enter
res ::= expr7;-- PARSER::expr7
--pSather
loop while!(next = at_tok);-- PARSER::next PARSER::at_tok
fetch;-- PARSER::fetch
h ::= #AS_AT_EXPR; h.source := source_loc;-- AS_AT_EXPR::create AS_AT_EXPR::source PARSER::source_loc
h.e := res; -- AS_AT_EXPR::e
if next = any_tok then-- PARSER::next PARSER::any_tok
h.at := #AS_ANY_EXPR;-- AS_AT_EXPR::at AS_ANY_EXPR::create
fetch;-- PARSER::fetch
else
h.at := expr7; -- AS_AT_EXPR::at PARSER::expr7
end;
res := h;
end;
exit;-- PARSER::exit
return res
end;
expr7: $AS_EXPR is
-- expr7 => expr6 {('and' | 'or') expr6}
--
enter("expression (prec = 7)");-- PARSER::enter
res ::= expr6;-- PARSER::expr6
loop
if check(and_tok) then-- PARSER::and_tok
a ::= #AS_AND_EXPR; a.source := source_loc;-- AS_AND_EXPR::create AS_AND_EXPR::source PARSER::source_loc
a.e1 := res; a.e2 := expr6; res := a-- AS_AND_EXPR::e1 AS_AND_EXPR::e2 PARSER::expr6
elsif check(or_tok) then-- PARSER::or_tok
o ::= #AS_OR_EXPR; o.source := source_loc;-- AS_OR_EXPR::create AS_OR_EXPR::source PARSER::source_loc
o.e1 := res; o.e2 := expr6; res := o-- AS_OR_EXPR::e1 AS_OR_EXPR::e2 PARSER::expr6
else break! end end;
exit;-- PARSER::exit
return res
end;
-- No mode specifiers allowed in sugared expressions
-- All args silently have ``in'' mode
expr6: $AS_EXPR is
-- expr6 => expr5 {('=' | '/=' | '<' | '<=' | '>=' | '>') expr5}
--
enter("expression (prec = 6)");-- PARSER::enter
res ::= expr5;-- PARSER::expr5
loop
name: IDENT;
if check(is_eq_tok) then-- PARSER::is_eq_tok
c::=#AS_CALL_EXPR; c.source:=source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.name:=IDENT_BUILTIN::is_eq_ident; c.ob:=res; c.args:=expr5; -- AS_CALL_EXPR::name IDENT_BUILTIN::is_eq_ident AS_CALL_EXPR::ob AS_CALL_EXPR::args PARSER::expr5
c.modes:=set_arg_modes(c,AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes PARSER::set_arg_modes AS_ARG_MODE::in_mode
res := c;
elsif check(is_neq_tok) then-- PARSER::is_neq_tok
c::=#AS_CALL_EXPR; c.source:=source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.name:=IDENT_BUILTIN::is_eq_ident; c.ob:=res; c.args:=expr5; -- AS_CALL_EXPR::name IDENT_BUILTIN::is_eq_ident AS_CALL_EXPR::ob AS_CALL_EXPR::args PARSER::expr5
c.modes:=set_arg_modes(c,AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes PARSER::set_arg_modes AS_ARG_MODE::in_mode
c2 ::= #AS_CALL_EXPR; c2.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c2.name := IDENT_BUILTIN::not_ident;-- AS_CALL_EXPR::name IDENT_BUILTIN::not_ident
c2.ob := c; res := c2-- AS_CALL_EXPR::ob
elsif check(is_lt_tok) then -- PARSER::is_lt_tok
c::=#AS_CALL_EXPR; c.source:=source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.name:=IDENT_BUILTIN::is_lt_ident; c.ob:=res; c.args:=expr5; -- AS_CALL_EXPR::name IDENT_BUILTIN::is_lt_ident AS_CALL_EXPR::ob AS_CALL_EXPR::args PARSER::expr5
c.modes:=set_arg_modes(c,AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes PARSER::set_arg_modes AS_ARG_MODE::in_mode
res := c;
elsif check(is_geq_tok) then-- PARSER::is_geq_tok
c::=#AS_CALL_EXPR; c.source:=source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.name:=IDENT_BUILTIN::is_lt_ident; c.ob:=res; c.args:=expr5; -- AS_CALL_EXPR::name IDENT_BUILTIN::is_lt_ident AS_CALL_EXPR::ob AS_CALL_EXPR::args PARSER::expr5
c.modes:=set_arg_modes(c,AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes PARSER::set_arg_modes AS_ARG_MODE::in_mode
c2 ::= #AS_CALL_EXPR; c2.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c2.name := IDENT_BUILTIN::not_ident;-- AS_CALL_EXPR::name IDENT_BUILTIN::not_ident
c2.ob := c; res := c2-- AS_CALL_EXPR::ob
elsif check(is_gt_tok) then-- PARSER::is_gt_tok
c::=#AS_CALL_EXPR; c.source:=source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.name:=IDENT_BUILTIN::is_lt_ident; c.ob:=res; c.args:=expr5; -- AS_CALL_EXPR::name IDENT_BUILTIN::is_lt_ident AS_CALL_EXPR::ob AS_CALL_EXPR::args PARSER::expr5
c.modes:=set_arg_modes(c,AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes PARSER::set_arg_modes AS_ARG_MODE::in_mode
c.flip:=true;-- AS_CALL_EXPR::flip
res := c;
elsif check(is_leq_tok) then-- PARSER::is_leq_tok
c::=#AS_CALL_EXPR; c.source:=source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.name:=IDENT_BUILTIN::is_lt_ident; c.ob:=res; c.args:=expr5; -- AS_CALL_EXPR::name IDENT_BUILTIN::is_lt_ident AS_CALL_EXPR::ob AS_CALL_EXPR::args PARSER::expr5
c.modes:=set_arg_modes(c,AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes PARSER::set_arg_modes AS_ARG_MODE::in_mode
c.flip:=true;-- AS_CALL_EXPR::flip
c2 ::= #AS_CALL_EXPR; c2.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c2.name := IDENT_BUILTIN::not_ident;-- AS_CALL_EXPR::name IDENT_BUILTIN::not_ident
c2.ob := c; res := c2-- AS_CALL_EXPR::ob
else break!
end;
end;
exit;-- PARSER::exit
return res
end;
set_arg_modes(c: AS_CALL_EXPR, m: INT): AS_ARG_MODE is
res: AS_ARG_MODE;
mode:AS_ARG_MODE;
a::=c.args;-- AS_CALL_EXPR::args
loop while!(~void(a));-- BOOL::not
mode := #AS_ARG_MODE(m);-- AS_ARG_MODE::create
if void(res) then
res := mode
else
res.append(mode)-- AS_ARG_MODE::append
end;
a := a.next;
end;
return res;
end;
expr5: $AS_EXPR is
-- expr5 => expr4 {('+' | '-') expr4}
--
enter("expression (prec = 5)");-- PARSER::enter
res ::= expr4;-- PARSER::expr4
loop
name:IDENT;
if check(plus_tok) then name := IDENT_BUILTIN::plus_ident-- PARSER::plus_tok IDENT_BUILTIN::plus_ident
elsif check(minus_tok) then name := IDENT_BUILTIN::minus_ident-- PARSER::minus_tok IDENT_BUILTIN::minus_ident
else break! end;
c ::= #AS_CALL_EXPR; c.source := source_loc; c.name := name;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc AS_CALL_EXPR::name
c.ob := res; c.args := expr4; -- AS_CALL_EXPR::ob AS_CALL_EXPR::args PARSER::expr4
-- set ``in'' arg modes
c.modes := set_arg_modes(c, AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes PARSER::set_arg_modes AS_ARG_MODE::in_mode
res := c end;
exit;-- PARSER::exit
return res
end;
expr4: $AS_EXPR is
-- expr4 => expr3 {('*' | '/' | '%') expr3}
--
enter("expression (prec = 4)");-- PARSER::enter
res ::= expr3;-- PARSER::expr3
loop
name:IDENT;
if check(times_tok) then name := IDENT_BUILTIN::times_ident-- PARSER::times_tok IDENT_BUILTIN::times_ident
elsif check(quotient_tok) then name := IDENT_BUILTIN::div_ident-- PARSER::quotient_tok IDENT_BUILTIN::div_ident
elsif check(mod_tok) then name := IDENT_BUILTIN::mod_ident-- PARSER::mod_tok IDENT_BUILTIN::mod_ident
else break! end;
c ::= #AS_CALL_EXPR; c.source := source_loc; c.name := name;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc AS_CALL_EXPR::name
c.ob := res; c.args := expr3; -- AS_CALL_EXPR::ob AS_CALL_EXPR::args PARSER::expr3
-- set ``in'' arg modes
c.modes := set_arg_modes(c, AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes PARSER::set_arg_modes AS_ARG_MODE::in_mode
res := c end;
exit;-- PARSER::exit
return res
end;
expr3: $AS_EXPR is
-- expr3 => '-' expr3 | '~' expr3 | exp2.
--
-- in case of literals and '-' do the negation directly to prevent
-- overflow in case of minint (e.g. -5 gets translated into 5.negate)
--
x: $AS_EXPR; c: AS_CALL_EXPR;
res: $AS_EXPR;
enter("expression (prec = 3)");-- PARSER::enter
if next = minus_tok then fetch; x := expr3;-- PARSER::next PARSER::minus_tok PARSER::fetch PARSER::expr3
typecase x
when AS_INT_LIT_EXPR then
i ::= #AS_INT_LIT_EXPR; i.source := source_loc;-- AS_INT_LIT_EXPR::create AS_INT_LIT_EXPR::source PARSER::source_loc
i.val := -x.val; res := i-- AS_INT_LIT_EXPR::val AS_INT_LIT_EXPR::val INTI::negate
when AS_FLT_LIT_EXPR then
f ::= #AS_FLT_LIT_EXPR; f.source := source_loc;-- AS_FLT_LIT_EXPR::create AS_FLT_LIT_EXPR::source PARSER::source_loc
f.val := -x.val; f.tp := x.tp; res := f-- AS_FLT_LIT_EXPR::val AS_FLT_LIT_EXPR::val RAT::negate AS_FLT_LIT_EXPR::tp AS_FLT_LIT_EXPR::tp
else
c := #AS_CALL_EXPR; c.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.name := IDENT_BUILTIN::negate_ident;-- AS_CALL_EXPR::name IDENT_BUILTIN::negate_ident
c.ob := x; res := c-- AS_CALL_EXPR::ob
end
elsif next = not_tok then fetch; x := expr3;-- PARSER::next PARSER::not_tok PARSER::fetch PARSER::expr3
c := #AS_CALL_EXPR; c.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.name := IDENT_BUILTIN::not_ident;-- AS_CALL_EXPR::name IDENT_BUILTIN::not_ident
c.ob := x; res := c-- AS_CALL_EXPR::ob
else res := expr2-- PARSER::expr2
end;
exit;-- PARSER::exit
return res
end;
expr2: $AS_EXPR is
-- expr2 => exp1 ['^' exp2]
--
enter("expression (prec = 2)");-- PARSER::enter
res ::= expr1(false);-- PARSER::expr1
if check(pow_tok) then-- PARSER::pow_tok
c ::= #AS_CALL_EXPR; c.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.name := IDENT_BUILTIN::pow_ident;-- AS_CALL_EXPR::name IDENT_BUILTIN::pow_ident
c.ob := res; c.args := expr2; -- AS_CALL_EXPR::ob AS_CALL_EXPR::args PARSER::expr2
-- set ``in'' arg modes
c.modes := set_arg_modes(c, AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes PARSER::set_arg_modes AS_ARG_MODE::in_mode
res := c end;
exit;-- PARSER::exit
return res
end;
expr_list (underscore_args:BOOL): $AS_EXPR is
-- expr_list => bound_arg {',' bound_arg}
-- bound_arg => expr | '_' [':' type_spec]
--
res: $AS_EXPR;
if underscore_args then enter("list of bound arguments")-- PARSER::enter
else enter("list of expressions") end;-- PARSER::enter
loop x: $AS_EXPR;
if check(under_tok) then-- PARSER::under_tok
u ::= #AS_UNDERSCORE_ARG; u.source := source_loc;-- AS_UNDERSCORE_ARG::create AS_UNDERSCORE_ARG::source PARSER::source_loc
u.source := source_loc; x := u;-- AS_UNDERSCORE_ARG::source PARSER::source_loc
if check(colon_tok) then u.tp := type_spec end;-- PARSER::colon_tok AS_UNDERSCORE_ARG::tp PARSER::type_spec
if ~underscore_args then-- BOOL::not
error("no underscore arguments allowed") end-- PARSER::error
else x := expr end;-- PARSER::expr
if void(res) then res := x
else res.append(x) end;
while!(check(comma_tok)) end;-- PARSER::comma_tok
exit;-- PARSER::exit
return res
end;
mode_expr_list (underscore_args:BOOL, is_iter:BOOL): TUP{$AS_EXPR, AS_ARG_MODE} is
-- mode_expr_list => bound_arg {',' bound_arg}
-- bound_arg => mode (expr | '_') [':' type_spec]
--
exprs: $AS_EXPR;
modes: AS_ARG_MODE;
m: AS_ARG_MODE;
if underscore_args then enter("list of bound arguments")-- PARSER::enter
else enter("list of expressions with modes") end;-- PARSER::enter
loop x: $AS_EXPR;
m := get_mode(is_iter);-- PARSER::get_mode
if check(under_tok) then-- PARSER::under_tok
u ::= #AS_UNDERSCORE_ARG; u.source := source_loc;-- AS_UNDERSCORE_ARG::create AS_UNDERSCORE_ARG::source PARSER::source_loc
u.source := source_loc; x := u;-- AS_UNDERSCORE_ARG::source PARSER::source_loc
if check(colon_tok) then -- PARSER::colon_tok
u.tp := type_spec; -- AS_UNDERSCORE_ARG::tp PARSER::type_spec
u.tp.mode := m; -- AS_UNDERSCORE_ARG::tp AS_TYPE_SPEC::mode
warning("Sather 1.1 disallows type specification for unbound arguments. The type is inferred from the context.");-- PARSER::warning
end;
if ~underscore_args then-- BOOL::not
error("no underscore arguments allowed")-- PARSER::error
end
else
-- if an iter and inside create (underscores allowed), then
-- must be a bound arg, so set mode to "once"
x := expr;-- PARSER::expr
if underscore_args and m.is_out_inout then-- AS_ARG_MODE::is_out_inout
error("out/inout arguments must be unbound");-- PARSER::error
end;
-- if underscore_args and is_iter then
-- m := #AS_ARG_MODE(AS_ARG_MODE::once_mode);
-- end;
end;
if void(exprs) then
exprs := x;
modes := m;
else
exprs.append(x);
modes.append(m);-- AS_ARG_MODE::append
end;
while!(check(comma_tok)) end;-- PARSER::comma_tok
exit;-- PARSER::exit
t:TUP{$AS_EXPR, AS_ARG_MODE} := #(exprs, modes);-- TUP{2}::create
return t;
end;
call_expr (ob: $AS_EXPR, tp: AS_TYPE_SPEC, underscore_args: BOOL): AS_CALL_EXPR is
-- call_expr => (ident | [ident] '!') ['(' mode_expr_list ')']
--
res: AS_CALL_EXPR;
enter("call expressions");-- PARSER::enter
res := #AS_CALL_EXPR; res.source := source_loc; res.ob := ob; res.tp := tp;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc AS_CALL_EXPR::ob AS_CALL_EXPR::tp
res.name := rout_or_iter_name;-- AS_CALL_EXPR::name PARSER::rout_or_iter_name
if check(lparen_tok) then -- PARSER::lparen_tok
-- always allow once? Check later? (Boris)
t ::= mode_expr_list(underscore_args, res.name.is_iter); -- PARSER::mode_expr_list AS_CALL_EXPR::name IDENT::is_iter
res.args := t.t1;-- AS_CALL_EXPR::args TUP{2}::t1
res.modes := t.t2;-- AS_CALL_EXPR::modes TUP{2}::t2
match(rparen_tok) -- PARSER::rparen_tok
end;
exit;-- PARSER::exit
return res
end;
type_of (x: $AS_EXPR): AS_TYPE_SPEC is
-- make sure x could be a type_spec
--
typecase x when AS_CALL_EXPR then
if void(x.ob) then-- AS_CALL_EXPR::ob
if void(x.tp) then-- AS_CALL_EXPR::tp
if is_class_name(x.name) then-- PARSER::is_class_name AS_CALL_EXPR::name
tp ::= #AS_TYPE_SPEC; tp.source := x.source;-- AS_TYPE_SPEC::create AS_TYPE_SPEC::source AS_CALL_EXPR::source
tp.kind := AS_TYPE_SPEC::ord;-- AS_TYPE_SPEC::kind AS_TYPE_SPEC::ord
tp.is_hot := false;-- AS_TYPE_SPEC::is_hot
tp.name := x.name;-- AS_TYPE_SPEC::name AS_CALL_EXPR::name
tp.params := void;-- AS_TYPE_SPEC::params
-- tp.mode := void;
tp.ret := void;-- AS_TYPE_SPEC::ret
return tp
end
else return x.tp-- AS_CALL_EXPR::tp
end
end
else end;
error("type specifier expected");-- PARSER::error
return void
end;
expr1 (underscore_args:BOOL): $AS_EXPR is
-- expr1 =>
-- (expr0 '.' call_expr | type_spec '::' call_expr |
-- call_expr | expr0 '[' expr_list ']')
-- {"." call_expr | '[' expr_list ']'}
--
-- (expr0 accepts type_specs for local_exprs)
--
enter("expression (prec = 1)");-- PARSER::enter
res ::= expr0;-- PARSER::expr0
c:AS_CALL_EXPR;
if check(dot_tok) then -- expr0 '.'-- PARSER::dot_tok
res := call_expr(res, void, underscore_args)-- PARSER::call_expr
elsif check(dcolon_tok) then -- type_spec '::'-- PARSER::dcolon_tok
res := call_expr(void, type_of(res), underscore_args)-- PARSER::call_expr PARSER::type_of
elsif check(iter_bang_tok) then -- part of call_expr: ident '!'-- PARSER::iter_bang_tok
c := #AS_CALL_EXPR; c.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.name := append_bang(ident_of(res));-- AS_CALL_EXPR::name PARSER::append_bang PARSER::ident_of
if check(lparen_tok) then -- PARSER::lparen_tok
t::= mode_expr_list(underscore_args, true); -- PARSER::mode_expr_list
c.args := t.t1;-- AS_CALL_EXPR::args TUP{2}::t1
c.modes := t.t2;-- AS_CALL_EXPR::modes TUP{2}::t2
match(rparen_tok) -- PARSER::rparen_tok
end;
res := c
elsif check(lparen_tok) then -- part of call_expr: ident '('-- PARSER::lparen_tok
c := #AS_CALL_EXPR; c.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.name := ident_of(res);-- AS_CALL_EXPR::name PARSER::ident_of
t ::= mode_expr_list(underscore_args, false); -- PARSER::mode_expr_list
c.args := t.t1; c.modes := t.t2;-- AS_CALL_EXPR::args TUP{2}::t1 AS_CALL_EXPR::modes TUP{2}::t2
match(rparen_tok);-- PARSER::rparen_tok
res := c
elsif check(lbracket_tok) then -- part of call_expr: expr0 '['-- PARSER::lbracket_tok
-- Only ``in'' arguments for array references (Boris)
c := #AS_CALL_EXPR; c.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.ob := res; c.args := expr_list(false); c.is_array := true;-- AS_CALL_EXPR::ob AS_CALL_EXPR::args PARSER::expr_list AS_CALL_EXPR::is_array
-- set ``in'' arg modes
c.modes := set_arg_modes(c, AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes PARSER::set_arg_modes AS_ARG_MODE::in_mode
match(rbracket_tok);-- PARSER::rbracket_tok
res := c
end;
loop
if check(dot_tok) then-- PARSER::dot_tok
res := call_expr(res, void, underscore_args)-- PARSER::call_expr
elsif check(lbracket_tok) then-- PARSER::lbracket_tok
c := #AS_CALL_EXPR; c.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
c.ob := res; c.args := expr_list(false); c.is_array := true;-- AS_CALL_EXPR::ob AS_CALL_EXPR::args PARSER::expr_list AS_CALL_EXPR::is_array
-- set ``in'' arg modes
c.modes := set_arg_modes(c, AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes PARSER::set_arg_modes AS_ARG_MODE::in_mode
match(rbracket_tok);-- PARSER::rbracket_tok
res := c
else break! end end;
exit;-- PARSER::exit
return res
end;
expr0: $AS_EXPR is
-- expr0 =>
-- self_expr | local_expr | void_expr | new_expr |
-- create_expr | array_expr | bound_create_expr |
-- except_expr | initial_expr | result_expr | while!_expr |
-- until!_expr | break!_expr | bool_lit_expr | char_lit_expr |
-- str_lit_expr | int_lit_expr | flt_lit_expr | '(' expr ')' |
-- '[' expr_list ']' |
-- here_expr | where_expr | near_expr | far_expr | any_expr
-- cluster_expr | cluster_bang_expr | | cluster_size| cohort_expr
--
-- local_expr accepts also type_spec, filtered out here or in expr1
--
enter("expression (prec = 0)");-- PARSER::enter
res: $AS_EXPR;
case next.val-- PARSER::next TOKEN::val
when self_tok then-- PARSER::self_tok
fetch; res := #AS_SELF_EXPR; res.source := source_loc-- PARSER::fetch AS_SELF_EXPR::create PARSER::source_loc
when ident_tok then-- PARSER::ident_tok
call_exp ::= #AS_CALL_EXPR; call_exp.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
if is_class_name(ident) then call_exp.tp := type_spec;-- PARSER::ident AS_CALL_EXPR::tp PARSER::type_spec
-- DPS changed from this
--if (call_exp.tp.kind = AS_TYPE_SPEC::ord) and void(call_exp.tp.params) then -- maybe ordinary call
-- call_exp.name := call_exp.tp.name;
-- call_exp.tp := void
--end
if (call_exp.tp.kind = AS_TYPE_SPEC::ord) then-- AS_CALL_EXPR::tp AS_TYPE_SPEC::kind INT::is_eq AS_TYPE_SPEC::ord
if void(call_exp.tp.params) then -- ordinary call-- AS_CALL_EXPR::tp AS_TYPE_SPEC::params
call_exp.name := call_exp.tp.name;-- AS_CALL_EXPR::name AS_CALL_EXPR::tp AS_TYPE_SPEC::name
call_exp.tp := void;-- AS_CALL_EXPR::tp
elsif next/=dcolon_tok then-- PARSER::next PARSER::dcolon_tok BOOL::not
error("This typespec neither preceeds '::' nor follows '#'");-- PARSER::error
end
end
else call_exp.name := ident; fetch end;-- AS_CALL_EXPR::name PARSER::ident PARSER::fetch
res := call_exp
when bang_tok then-- PARSER::bang_tok
r ::= #AS_CALL_EXPR; r.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
r.name := IDENT_BUILTIN::bang_ident; fetch;-- AS_CALL_EXPR::name IDENT_BUILTIN::bang_ident PARSER::fetch
res := r
when iter_bang_tok then-- PARSER::iter_bang_tok
r ::= #AS_CALL_EXPR; r.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
r.name := IDENT_BUILTIN::bang_ident; fetch;-- AS_CALL_EXPR::name IDENT_BUILTIN::bang_ident PARSER::fetch
res := r
when SAME_tok then-- PARSER::SAME_tok
r ::= #AS_CALL_EXPR; r.source := source_loc;-- AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
r.tp := type_spec;-- AS_CALL_EXPR::tp PARSER::type_spec
if next/=dcolon_tok then-- PARSER::next PARSER::dcolon_tok BOOL::not
error("`SAME' neither preceeds '::' nor follows '#'");-- PARSER::error
end;
res := r
when void_tok then-- PARSER::void_tok
enter("void expressions");-- PARSER::enter
fetch;-- PARSER::fetch
if next = lparen_tok then fetch;-- PARSER::next PARSER::lparen_tok PARSER::fetch
vtest ::= #AS_IS_VOID_EXPR; vtest.source := source_loc;-- AS_IS_VOID_EXPR::create AS_IS_VOID_EXPR::source PARSER::source_loc
vtest.arg := expr; res := vtest;-- AS_IS_VOID_EXPR::arg PARSER::expr
match(rparen_tok)-- PARSER::rparen_tok
else res := #AS_VOID_EXPR; res.source := source_loc-- AS_VOID_EXPR::create PARSER::source_loc
end;
exit-- PARSER::exit
when new_tok then-- PARSER::new_tok
enter("new expression");-- PARSER::enter
fetch;-- PARSER::fetch
new_ex ::= #AS_NEW_EXPR; new_ex.source := source_loc;-- AS_NEW_EXPR::create AS_NEW_EXPR::source PARSER::source_loc
res := new_ex;
if check(lparen_tok) then-- PARSER::lparen_tok
new_ex.arg := expr;-- AS_NEW_EXPR::arg PARSER::expr
match(rparen_tok) end;-- PARSER::rparen_tok
exit-- PARSER::exit
when sharp_tok then fetch;-- PARSER::sharp_tok PARSER::fetch
if (next = ROUT_tok) or (next = ITER_tok) then-- PARSER::next PARSER::ROUT_tok PARSER::next PARSER::ITER_tok
res := bound_create_expr-- PARSER::bound_create_expr
else res := create_expr end-- PARSER::create_expr
when bind_tok then res := bound_create_expr -- PARSER::bind_tok PARSER::bound_create_expr
when vbar_tok then-- PARSER::vbar_tok
enter("array expression");-- PARSER::enter
fetch;-- PARSER::fetch
arr_ex ::= #AS_ARRAY_EXPR; arr_ex.source := source_loc;-- AS_ARRAY_EXPR::create AS_ARRAY_EXPR::source PARSER::source_loc
res := arr_ex;
arr_ex.elts := expr_list(false); -- AS_ARRAY_EXPR::elts PARSER::expr_list
match(vbar_tok);-- PARSER::vbar_tok
exit-- PARSER::exit
when exception_tok then-- PARSER::exception_tok
fetch; res := #AS_EXCEPT_EXPR; res.source := source_loc;-- PARSER::fetch AS_EXCEPT_EXPR::create PARSER::source_loc
when initial_tok then-- PARSER::initial_tok
enter("initial expression");-- PARSER::enter
fetch; match(lparen_tok);-- PARSER::fetch PARSER::lparen_tok
init_ex ::= #AS_INITIAL_EXPR; init_ex.source := source_loc;-- AS_INITIAL_EXPR::create AS_INITIAL_EXPR::source PARSER::source_loc
res := init_ex;
init_ex.e := expr;-- AS_INITIAL_EXPR::e PARSER::expr
match(rparen_tok);-- PARSER::rparen_tok
exit-- PARSER::exit
when result_tok then-- PARSER::result_tok
fetch; res := #AS_RESULT_EXPR; res.source := source_loc;-- PARSER::fetch AS_RESULT_EXPR::create PARSER::source_loc
when while_tok then-- PARSER::while_tok
enter("while! expression");-- PARSER::enter
fetch; match(lparen_tok); res := expr; match(rparen_tok);-- PARSER::fetch PARSER::lparen_tok PARSER::expr PARSER::rparen_tok
error("while! expression must stand alone");-- PARSER::error
exit-- PARSER::exit
when until_tok then-- PARSER::until_tok
enter("until! expression");-- PARSER::enter
fetch; match(lparen_tok); res := expr; match(rparen_tok);-- PARSER::fetch PARSER::lparen_tok PARSER::expr PARSER::rparen_tok
error("until! expression must stand alone");-- PARSER::error
exit-- PARSER::exit
when break_tok then-- PARSER::break_tok
fetch; res := #AS_BOOL_LIT_EXPR; res.source := source_loc;-- PARSER::fetch AS_BOOL_LIT_EXPR::create PARSER::source_loc
error("break! expression must stand alone")-- PARSER::error
when true_tok then-- PARSER::true_tok
r ::= #AS_BOOL_LIT_EXPR; r.source := source_loc;-- AS_BOOL_LIT_EXPR::create AS_BOOL_LIT_EXPR::source PARSER::source_loc
r.val := next = true_tok; res := r; fetch-- AS_BOOL_LIT_EXPR::val PARSER::next PARSER::true_tok PARSER::fetch
when false_tok then-- PARSER::false_tok
r ::= #AS_BOOL_LIT_EXPR; r.source := source_loc;-- AS_BOOL_LIT_EXPR::create AS_BOOL_LIT_EXPR::source PARSER::source_loc
r.val := next = true_tok; res := r; fetch-- AS_BOOL_LIT_EXPR::val PARSER::next PARSER::true_tok PARSER::fetch
when lchar_tok then-- PARSER::lchar_tok
c ::= #AS_CHAR_LIT_EXPR; c.source := source_loc;-- AS_CHAR_LIT_EXPR::create AS_CHAR_LIT_EXPR::source PARSER::source_loc
c.val := scanner.char_value.int; -- AS_CHAR_LIT_EXPR::val PARSER::scanner SCANNER::char_value CHAR::int
res := c; fetch-- PARSER::fetch
when lstr_tok then-- PARSER::lstr_tok
s ::= #AS_STR_LIT_EXPR; s.source := source_loc;-- AS_STR_LIT_EXPR::create AS_STR_LIT_EXPR::source PARSER::source_loc
s.s := ident.str; res := s; fetch-- AS_STR_LIT_EXPR::s PARSER::ident IDENT::str PARSER::fetch
when lint_tok then-- PARSER::lint_tok
assert scanner.num_value.is_int;-- PARSER::scanner SCANNER::num_value RAT::is_int
i ::= #AS_INT_LIT_EXPR; i.source := source_loc;-- AS_INT_LIT_EXPR::create AS_INT_LIT_EXPR::source PARSER::source_loc
i.val := scanner.num_value.floor;-- AS_INT_LIT_EXPR::val PARSER::scanner SCANNER::num_value RAT::floor
i.is_inti := (scanner.value_type = AS_FLT_LIT_EXPR::flti);-- AS_INT_LIT_EXPR::is_inti PARSER::scanner SCANNER::value_type INT::is_eq AS_FLT_LIT_EXPR::flti
res := i;
fetch-- PARSER::fetch
when lflt_tok then-- PARSER::lflt_tok
f ::= #AS_FLT_LIT_EXPR; f.source := source_loc;-- AS_FLT_LIT_EXPR::create AS_FLT_LIT_EXPR::source PARSER::source_loc
f.val := scanner.num_value;-- AS_FLT_LIT_EXPR::val PARSER::scanner SCANNER::num_value
f.tp := scanner.value_type;-- AS_FLT_LIT_EXPR::tp PARSER::scanner SCANNER::value_type
res := f; fetch-- PARSER::fetch
when lparen_tok then-- PARSER::lparen_tok
fetch; res := expr; match(rparen_tok)-- PARSER::fetch PARSER::expr PARSER::rparen_tok
when lbracket_tok then-- PARSER::lbracket_tok
fetch; a ::= #AS_CALL_EXPR; a.source := source_loc;-- PARSER::fetch AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
a.args := expr_list(false); a.is_array := true; -- AS_CALL_EXPR::args PARSER::expr_list AS_CALL_EXPR::is_array
-- set ``in'' arg modes
a.modes := set_arg_modes(a, AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes PARSER::set_arg_modes AS_ARG_MODE::in_mode
res := a;
match(rbracket_tok)-- PARSER::rbracket_tok
when here_tok then-- PARSER::here_tok
fetch; res := #AS_HERE_EXPR; res.source := source_loc-- PARSER::fetch AS_HERE_EXPR::create PARSER::source_loc
-- when any_tok then
-- fetch; res := #AS_ANY_EXPR; res.source := source_loc
when cluster_tok then-- PARSER::cluster_tok
fetch; res := #AS_CLUSTER_EXPR; res.source := source_loc-- PARSER::fetch AS_CLUSTER_EXPR::create PARSER::source_loc
when cluster_size_tok then-- PARSER::cluster_size_tok
fetch; res := #AS_CLUSTER_SIZE_EXPR; res.source := source_loc -- PARSER::fetch AS_CLUSTER_SIZE_EXPR::create PARSER::source_loc
when cluster_bang_tok then-- PARSER::cluster_bang_tok
fetch; r ::= #AS_CALL_EXPR; r.source := source_loc;-- PARSER::fetch AS_CALL_EXPR::create AS_CALL_EXPR::source PARSER::source_loc
r.tp := #AS_TYPE_SPEC;-- AS_CALL_EXPR::tp AS_TYPE_SPEC::create
r.tp.name := IDENT_BUILTIN::SYS_ident;-- AS_CALL_EXPR::tp AS_TYPE_SPEC::name IDENT_BUILTIN::SYS_ident
r.name := #IDENT("builtin_clusters!");-- AS_CALL_EXPR::name IDENT::create
res := r;
when cohort_tok then-- PARSER::cohort_tok
fetch; res := #AS_COHORT_EXPR; res.source := source_loc;-- PARSER::fetch AS_COHORT_EXPR::create PARSER::source_loc
when where_tok then-- PARSER::where_tok
enter("where expression");-- PARSER::enter
r ::= #AS_WHERE_EXPR; r.source := source_loc; res := r;-- AS_WHERE_EXPR::create AS_WHERE_EXPR::source PARSER::source_loc
fetch; match(lparen_tok); r.e := expr; match(rparen_tok);-- PARSER::fetch PARSER::lparen_tok AS_WHERE_EXPR::e PARSER::expr PARSER::rparen_tok
exit-- PARSER::exit
when near_tok then-- PARSER::near_tok
enter("near expression");-- PARSER::enter
r ::= #AS_NEAR_EXPR; r.source := source_loc; res := r;-- AS_NEAR_EXPR::create AS_NEAR_EXPR::source PARSER::source_loc
fetch; match(lparen_tok); r.e := expr; match(rparen_tok);-- PARSER::fetch PARSER::lparen_tok AS_NEAR_EXPR::e PARSER::expr PARSER::rparen_tok
exit-- PARSER::exit
when far_tok then-- PARSER::far_tok
enter("far expression");-- PARSER::enter
r ::= #AS_FAR_EXPR; r.source := source_loc; res := r;-- AS_FAR_EXPR::create AS_FAR_EXPR::source PARSER::source_loc
fetch; match(lparen_tok); r.e := expr; match(rparen_tok);-- PARSER::fetch PARSER::lparen_tok AS_FAR_EXPR::e PARSER::expr PARSER::rparen_tok
exit-- PARSER::exit
else exp_error("expression"); res := #AS_VOID_EXPR; res.source := source_loc end;-- PARSER::exp_error AS_VOID_EXPR::create PARSER::source_loc
exit;-- PARSER::exit
return res
end;
check_underscores (call:AS_CALL_EXPR, is_iter:BOOL) is
if void(call) then return; end;
if call.name.is_iter /= is_iter then-- AS_CALL_EXPR::name IDENT::is_iter BOOL::is_eq BOOL::not
if is_iter then error("bound routine must be an iter")-- PARSER::error
else error("bound routine must not be an iter") end end;-- PARSER::error
if call.is_array then-- AS_CALL_EXPR::is_array
error("only call expressions allowed") end;-- PARSER::error
ob: $AS_EXPR := call.ob;-- AS_CALL_EXPR::ob
loop until!(void(ob));
this: $AS_EXPR := ob;
typecase this when AS_CALL_EXPR then
ob := this.ob;-- AS_CALL_EXPR::ob
arg: $AS_EXPR := this.args;-- AS_CALL_EXPR::args
loop until!(void(arg));
typecase arg when AS_UNDERSCORE_ARG then
error("illegal underscore arguments");-- PARSER::error
return
else end;
arg := arg.next
end
else
typecase ob when AS_UNDERSCORE_ARG then
if ~SYS::ob_eq(ob, call.ob) then-- SYS::ob_eq AS_CALL_EXPR::ob BOOL::not
error("illegal underscore arguments")-- PARSER::error
end
else end;
return
end
end
end;
bound_create_expr: AS_BOUND_CREATE_EXPR is
-- bound_create_expr =>
-- 'bind' '('
-- ('_' [':' type_spec] '.' call_expr | expr1)
-- [':' type_spec] ')'
--
-- '#' already seen and stripped away
-- next is one of ROUT_tok, bind_tok, ITER_tok (guaranteed)
--
enter("bound create expression");-- PARSER::enter
if next = ITER_tok then-- PARSER::next PARSER::ITER_tok
convert.convert_bind;-- PARSER::convert CONVERT::convert_bind
if ~version_1_0 then-- PARSER::version_1_0 BOOL::not
prog.set_eloc(source_loc);-- PARSER::prog PROG::set_eloc PARSER::source_loc
prog.warning("#ITER() is obsolete. Use bind() instead.");-- PARSER::prog PROG::warning
end;
else
if next=ROUT_tok then-- PARSER::next PARSER::ROUT_tok
convert.convert_bind; -- PARSER::convert CONVERT::convert_bind
if ~version_1_0 then-- PARSER::version_1_0 BOOL::not
prog.set_eloc(source_loc);-- PARSER::prog PROG::set_eloc PARSER::source_loc
prog.warning("#ROUT() is obsolete. Use bind() instead.");-- PARSER::prog PROG::warning
end;
end;
end;
res ::= #AS_BOUND_CREATE_EXPR; res.source := source_loc;-- AS_BOUND_CREATE_EXPR::create AS_BOUND_CREATE_EXPR::source PARSER::source_loc
fetch;-- PARSER::fetch
match(lparen_tok);-- PARSER::lparen_tok
if check(under_tok) then-- PARSER::under_tok
u ::= #AS_UNDERSCORE_ARG; u.source := source_loc;-- AS_UNDERSCORE_ARG::create AS_UNDERSCORE_ARG::source PARSER::source_loc
if check(colon_tok) then -- PARSER::colon_tok
u.tp := type_spec;-- AS_UNDERSCORE_ARG::tp PARSER::type_spec
warning("Sather 1.1 disallows type specification for unbound arguments. The type is inferred from the context."); -- PARSER::warning
end;
match(dot_tok);-- PARSER::dot_tok
res.call := call_expr(u, void, true) --later prohibit once? (Boris)-- AS_BOUND_CREATE_EXPR::call PARSER::call_expr
else -- hack: should be improved
x ::= expr1(true);-- PARSER::expr1
typecase x
when AS_CALL_EXPR then res.call := x -- AS_BOUND_CREATE_EXPR::call
else error("bound create must have a routine");-- PARSER::error
end
end;
res.is_iter := res.call.name.is_iter;-- AS_BOUND_CREATE_EXPR::is_iter AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::name IDENT::is_iter
check_underscores(res.call, res.is_iter);-- PARSER::check_underscores AS_BOUND_CREATE_EXPR::call AS_BOUND_CREATE_EXPR::is_iter
if check(colon_tok) then res.ret := type_spec end;-- PARSER::colon_tok AS_BOUND_CREATE_EXPR::ret PARSER::type_spec
match(rparen_tok);-- PARSER::rparen_tok
exit;-- PARSER::exit
return res
end;
create_expr: AS_CREATE_EXPR is
-- create_expr => '#' [type_spec] ['(' mode_expr_list ')']
--
-- '#' already seen and stripped away
--
enter("create expression");-- PARSER::enter
res ::= #AS_CREATE_EXPR; res.source := source_loc;-- AS_CREATE_EXPR::create AS_CREATE_EXPR::source PARSER::source_loc
if (next = ident_tok) or (next = SAME_tok) then res.tp := type_spec-- PARSER::next PARSER::ident_tok PARSER::next PARSER::SAME_tok AS_CREATE_EXPR::tp PARSER::type_spec
elsif next = type_name_tok then res.tp := type_spec;-- PARSER::next PARSER::type_name_tok AS_CREATE_EXPR::tp PARSER::type_spec
error("no abstract types allowed")-- PARSER::error
end;
if check(lparen_tok) then-- PARSER::lparen_tok
t::= mode_expr_list(false, false);-- PARSER::mode_expr_list
res.elts := t.t1; res.modes := t.t2;-- AS_CREATE_EXPR::elts TUP{2}::t1 AS_CREATE_EXPR::modes TUP{2}::t2
match(rparen_tok) -- PARSER::rparen_tok
end;
exit;-- PARSER::exit
return res
end;
end; -- PARSER
class PARSE < $PARSE
class PARSE < $PARSE is
-- The phase in which all files are parsed and tree forms built.
-- This phase catches both syntactic errors and multiply defined
-- classes.
include CS_COMPONENT;
attr parsed:FSET{STR}; -- Table of already parsed files.
attr has:FMAP{STR,STR}; -- Files containing classes given by -has
attr known_files:FSET{STR}; -- Files that we know all classes by -has
attr convert_files:FSET{STR}; -- Files needed to convert to 1.1 syntax
attr convert_all:BOOL; -- true if all files are to be converted to 1.1
attr version_1_0:BOOL; -- true if Sather 1.0 source is compiled
private attr missing_classes: FSET{STR};
-- Names of classes which were not found.
create(p:PROG):SAME
is
r::=new; r.prog:=p; return r-- PARSE::prog
end;
tree_for(nm:IDENT, num:INT):AS_CLASS_DEF is
-- Return the code tree for the class with name `nm' and the
-- number of type parameters `num'. Return void if no such class.
searchtag ::= #TUP{IDENT,INT}(nm,num);-- TUP{2}::create
r ::= prog.as_tbl.get_query(searchtag);-- PARSE::prog PROG::as_tbl PROG_AS_TBL::get_query
if ~void(r) then return r end;-- BOOL::not
-- If we haven't found it, try the -has files
fn::=has.get(nm.str);-- PARSE::has FMAP{2}::get IDENT::str
if ~void(fn) then-- BOOL::not
perform_parse(fn);-- PARSE::perform_parse
r := prog.as_tbl.get_query(searchtag);-- PARSE::prog PROG::as_tbl PROG_AS_TBL::get_query
end;
if void(r) then
class_name: STR := nm.str(num);-- IDENT::str
if ~missing_classes.test(class_name) then-- PARSE::missing_classes FSET{1}::test BOOL::not
prog.err("There is no class named " + class_name + ".");-- PARSE::prog PROG::err STR::plus STR::plus
missing_classes := missing_classes.insert(class_name);-- PARSE::missing_classes PARSE::missing_classes FSET{1}::insert
end;
end;
return r;
end;
parse(f:STR) is
-- We can check out known files later; don't bother parsing now.
-- This avoids parsing files that aren't referenced and even
-- if they are, speeds up the presentation of semantic errors
-- that would otherwise have to wait for parsing everything to
-- finish.
if known_files.test(f) then return;-- PARSE::known_files FSET{1}::test
else perform_parse(f);-- PARSE::perform_parse
end;
end;
private perform_parse(f:STR) is
-- Tell the parser to parse the file `f', put the tree in `as_tbl'.
-- If we've already done it
if parsed.test(f) then return; end;-- PARSE::parsed FSET{1}::test
parsed:=parsed.insert(f);-- PARSE::parsed PARSE::parsed FSET{1}::insert
if prog.show_parse_file then #OUT + "(Parse " + f + ") " end;-- PARSE::prog PROG::show_parse_file OUT::create OUT::plus OUT::plus OUT::plus
parser ::= #PARSER(prog, f, prog.psather, (convert_files.test(f) or convert_all), version_1_0 or convert_files.test(f) or convert_all);-- PARSER::create PARSE::prog PARSE::prog PROG::psather PARSE::convert_files FSET{1}::test PARSE::convert_all PARSE::version_1_0 PARSE::convert_files FSET{1}::test PARSE::convert_all
if ~void(parser) then-- BOOL::not
tcd: AS_CLASS_DEF := parser.source_file;-- PARSER::source_file
loop until!(void(tcd));
if prog.show_as_insert then-- PARSE::prog PROG::show_as_insert
#OUT+"(Tree for "+tcd.name.str+"("+tcd.params.size+")) ";-- OUT::create OUT::plus OUT::plus AS_CLASS_DEF::name IDENT::str OUT::plus OUT::plus AS_CLASS_DEF::params AS_PARAM_DEC::size OUT::plus
end;
ntcd:AS_CLASS_DEF:=tcd.next; tcd.next:=void;-- AS_CLASS_DEF::next AS_CLASS_DEF::next
typetag ::= #TUP{IDENT,INT}(tcd.name,tcd.params.size);-- TUP{2}::create AS_CLASS_DEF::name AS_CLASS_DEF::params AS_PARAM_DEC::size
if prog.as_tbl.test_query(typetag) then-- PARSE::prog PROG::as_tbl PROG_AS_TBL::test_query
other_class:AS_CLASS_DEF := prog.as_tbl.get_query(typetag);-- PARSE::prog PROG::as_tbl PROG_AS_TBL::get_query
dup_class_err(tcd,other_class);-- PARSE::dup_class_err
else
prog.as_tbl := prog.as_tbl.insert(tcd)-- PARSE::prog PROG::as_tbl PARSE::prog PROG::as_tbl PROG_AS_TBL::insert
end;
tcd:=ntcd
end
end;
-- pSather
-- create AS_ROUT_DEF for clusters! here
-- clusters! cannot be provided by sys.sa, since, clusters! is
-- a keyword.
-- if f=has.get("SYS") and prog.psather then
-- sysclass::=prog.as_tbl.get_query(#(#IDENT("SYS"),0));
-- body::=sysclass.body;
-- loop
-- until!(void(body.next));
-- body := body.next;
-- end;
--
-- cl_it::=#AS_ROUT_DEF;
-- cl_it.name:=#IDENT("clusters!");
-- cl_it.ret_dec:=#AS_TYPE_SPEC;
-- cl_it.ret_dec.name :=#IDENT("INT");
-- cl_it.body:=#AS_STMT_LIST;
-- cl_it_r ::= #AS_RAISE_STMT;
-- cl_it_r.surr_stmt_list := cl_it.body;
-- cl_it.body.stmts := cl_it_r;
-- body.append(cl_it);
-- end; -- pSather
end; -- of parse
private dup_class_err(this_class,other_class:AS_CLASS_DEF) is
err_loc(this_class);-- PARSE::err_loc
err("There are two classes with the name " + this_class.name.str +-- PARSE::err STR::plus AS_CLASS_DEF::name IDENT::str
" and " + this_class.params.size + " parameters.\n\t" -- STR::plus STR::plus AS_CLASS_DEF::params AS_PARAM_DEC::size
"The other one is at:"+other_class.source.str ) -- STR::plus STR::plus AS_CLASS_DEF::source SFILE_ID::str
end;
end; -- class PARSE