334 lines
7.5 KiB
Text
334 lines
7.5 KiB
Text
//*****************************************************************************
|
|
// $RCSfile: std.tdl,v $
|
|
// $Revision: 1.2 $
|
|
// $Date: 2002/03/08 15:54:33 $
|
|
// Author: Markus Kern
|
|
//*****************************************************************************
|
|
/*
|
|
Contains language independent procedures and templates. These are used by the
|
|
language dependent code generators.
|
|
See the documentation for a description of these procedures and templates
|
|
*/
|
|
|
|
//------------------------------------------------------------------------------
|
|
proc setCount(count)
|
|
[__COUNT__] = [count];
|
|
end proc
|
|
|
|
proc addCount(number)
|
|
[__COUNT__] = add([__COUNT__],[number]);
|
|
end proc
|
|
|
|
proc getCount()
|
|
return [__COUNT__];
|
|
end proc
|
|
|
|
proc setDelim(delim)
|
|
[__DELIM__] = [delim];
|
|
end proc
|
|
|
|
proc delim()
|
|
return [__DELIM__];
|
|
end proc
|
|
|
|
proc setVar(varName, varValue)
|
|
[[varName]] = [varValue];
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
proc setString(init)
|
|
[__INIT__] = [init];
|
|
return [init];
|
|
end proc
|
|
|
|
proc getString()
|
|
local txt = [__INIT__];
|
|
[__INIT__] = "";
|
|
return [txt];
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
tcl_proc add(num1, num2)
|
|
return [expr $num1 + $num2]
|
|
end proc
|
|
|
|
tcl_proc sub(num1, num2)
|
|
return [expr $num1 - $num2]
|
|
end proc
|
|
|
|
tcl_proc mul(num1, num2)
|
|
return [expr $num1 * $num2]
|
|
end proc
|
|
|
|
tcl_proc div(num1, num2)
|
|
return [expr $num1 / $num2]
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
tcl_proc time()
|
|
return [clock format [clock seconds] -format "%X"]
|
|
end proc
|
|
|
|
tcl_proc date()
|
|
return [clock format [clock seconds] -format "%x"]
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
tcl_proc hostname()
|
|
return [info hostname]
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
tcl_proc replace(str, expr, subSpec)
|
|
set ret "";
|
|
regsub -all $expr $str $subSpec ret;
|
|
return $ret;
|
|
end proc
|
|
|
|
tcl_proc toUpper(str)
|
|
return [string toupper $str];
|
|
end proc
|
|
|
|
tcl_proc toLower(str)
|
|
return [string tolower $str];
|
|
end proc
|
|
|
|
tcl_proc getLength(str)
|
|
return [string length $str];
|
|
end proc
|
|
|
|
tcl_proc lsdir(dir)
|
|
return [file dirname $dir];
|
|
end proc
|
|
|
|
tcl_proc mkdir(dir)
|
|
file mkdir $dir;
|
|
end proc
|
|
|
|
tcl_proc dirName(file)
|
|
set dirName [file dirname $file];
|
|
if { $dirName == "" } { return "";}
|
|
set delim "/"
|
|
return $dirName$delim;
|
|
end proc
|
|
|
|
tcl_proc fileName(file)
|
|
set fileList [file split $file]
|
|
return [lindex $fileList [ expr [llength $fileList] - 1]]
|
|
end proc
|
|
|
|
tcl_proc regexp(str,reg)
|
|
set ret ""
|
|
regexp $reg $str ret;
|
|
return $ret;
|
|
end proc
|
|
|
|
tcl_proc createString(str,count)
|
|
set x 0
|
|
set ret ""
|
|
while {$x < $count} {
|
|
set ret $ret$str
|
|
incr x
|
|
}
|
|
return $ret
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
tcl_proc invIdOrder(list)
|
|
set invList "";
|
|
set li [split $list " "];
|
|
foreach {elem} $li {
|
|
set invList [concat $elem $invList]
|
|
}
|
|
return $invList
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
proc isExternal(MClass)
|
|
loop(MClass->Note->Item
|
|
Where [Item.value] == "True" AND [Item.type] == "UmlClassIsImported")
|
|
return TRUE;
|
|
end loop
|
|
return FALSE;
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
proc getStereotype(MSemElement)
|
|
loop(MSemElement->Stereotype)
|
|
return [Stereotype.name];
|
|
end loop
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
proc getMultiplicity(multiplicity)
|
|
|
|
switch([multiplicity])
|
|
case "":
|
|
case "1":
|
|
case "0..1":
|
|
case "1..0":
|
|
case "0..0":
|
|
return "One";
|
|
|
|
case "*":
|
|
case "1..*":
|
|
case "n":
|
|
case "N":
|
|
return "Many";
|
|
|
|
case regexp([multiplicity],"[0-9]+"):
|
|
return [multiplicity];
|
|
|
|
case regexp([multiplicity],"[0-9]+\.\.[0-9]+"):
|
|
return split([multiplicity],".","T");
|
|
|
|
default:
|
|
return "Many";
|
|
|
|
end switch
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
tcl_proc split(str,delim,pos)
|
|
|
|
set li [split $str $delim];
|
|
switch $pos {
|
|
"L" {
|
|
return [lindex $li 0]
|
|
}
|
|
|
|
"T" {
|
|
return [lindex $li [ expr [llength $li] - 1]]
|
|
}
|
|
|
|
default {
|
|
return [lindex $li $pos]
|
|
}
|
|
}
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
proc setText(init)
|
|
[__INIT__] = [init];
|
|
return [init];
|
|
end proc
|
|
|
|
proc getText()
|
|
local txt = [__INIT__];
|
|
[__INIT__] = "";
|
|
return [txt];
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
proc outText(text,delim1,delim2)
|
|
local ret;
|
|
loop(Instances->TokenSet([text]);setString([delim1]);setString("\n" [delim2]))
|
|
[ret] = [ret] getString()[TokenSet.line];
|
|
end loop
|
|
return [ret];
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
proc safeOutput(fileName)
|
|
mkdir(lsdir([fileName]));
|
|
setOutput([fileName]);
|
|
|
|
// This comes last, so that it holds the correct value during the insert/mark fixup process
|
|
[ACT_OUTPUT_FILE] = [fileName];
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
proc output(fileName)
|
|
mkdir(lsdir([fileName]));
|
|
setOutput(dirName([fileName])"_"fileName([fileName]));
|
|
appendMergeFile([fileName]);
|
|
|
|
// This comes last, so that it holds the correct value during the insert/mark fixup process
|
|
[ACT_OUTPUT_FILE] = [fileName];
|
|
end proc
|
|
|
|
|
|
proc getOutput()
|
|
return [ACT_OUTPUT_FILE];
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
proc setLanguage(language)
|
|
[ACT_LANGUAGE] = [language];
|
|
end proc
|
|
|
|
// Generate the id list for the class(es) with specified name.
|
|
// Note that we normally expect a single MClass in the list.
|
|
// This was introduced to improve the code generator performance.
|
|
proc MClass_ids_by_name (name)
|
|
|
|
local x = "MClass_by_name_Cache_For_" [name];
|
|
|
|
if ([[x]] == "")
|
|
loop(Instances -> MClass where [MClass.name] == [name])
|
|
[[x]] = [[x]] " " [MClass.id];
|
|
//T info = "MClass_ids_by_name #" [x]" -> "[[x]]"\n";
|
|
end loop
|
|
end if
|
|
|
|
//T info = "MClass_ids_by_name :" [x]" -> "[[x]]"\n";
|
|
return [[x]];
|
|
end proc
|
|
|
|
proc getDataType(type)
|
|
loop(Instances->MClass(MClass_ids_by_name ([type]))->MDataType->TaggedValue
|
|
Where [TaggedValue.tag] == [ACT_LANGUAGE])
|
|
return [TaggedValue.value];
|
|
end loop
|
|
//info = "MClass_ids_by_name #" [ACT_LANGUAGE] "\n";
|
|
return [type];
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
template genLines(Lines)
|
|
[loop(Instances->TokenSet([Lines]))]
|
|
[TokenSet.line]
|
|
[end loop]
|
|
end template
|
|
|
|
//------------------------------------------------------------------------------
|
|
proc getUniqueId(MElement)
|
|
loop (MElement->MSemElement where [MSemElement.guid] != "")
|
|
return [MSemElement.guid];
|
|
end loop
|
|
return [MElement.id];
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
tcl_proc appendMergeFile(fileName)
|
|
catch {
|
|
set file [open "_acdGeneratedFiles.mrg" "a"];
|
|
puts $file $fileName;
|
|
close $file
|
|
}
|
|
end proc
|
|
|
|
//------------------------------------------------------------------------------
|
|
tcl_proc delMergeFile()
|
|
catch {
|
|
file delete "_acdGeneratedFiles.mrg"
|
|
}
|
|
end proc
|
|
|
|
// ECR 5664 begin
|
|
|
|
tcl_proc substring(text, first, last)
|
|
return [string range $text $first $last];
|
|
end proc
|
|
|
|
tcl_proc searchstr(text, str, start)
|
|
variable res
|
|
set res [string first $str [string range $text $start end]]
|
|
if {$res == -1} {
|
|
return -1
|
|
} else {
|
|
return [expr $start + $res]
|
|
}
|
|
end proc
|
|
|
|
// ECR 5664 end
|