UNIT Generation.ms.dict
USES
params.ms.dict
;
USES
axiom_push.ms.dict
;
USES
core.ms.dict
;
USES
Log.ms.dict
;
USES
WordsRTTI.ms.dict
;
USES
ElementsRTTI.ms.dict
;
USES
CompileTimeVar.ms.dict
;
USES
SaveVarAndDo.ms.dict
;
CONST cPathSep '\'
FILE CompileTime-VAR g_OutFile nil
%REMARK 'Текущий файл'
STRING CompileTime-VAR g_Indent ''
%REMARK 'Текущий отступ'
CONST cIndentChar ' '
STRING FUNCTION IndentStr
g_Indent >>> Result
; // IndentStr
OBJECT STRING INTEGER ARRAY BOOLEAN TYPE OUTABLE
CONST \n #13#10
CONST cQuote ''''
CONST cOpenComment '{'
CONST cCloseComment '}'
CONST cSpace ' '
CONST cUnderline '_'
CONST cDot '.'
CONST cEmptyStr ''
BOOLEAN CompileTime-VAR g_EnableAutoEOL true
BOOLEAN CompileTime-VAR g_NeedOutLn false
PROCEDURE OutLnToFile
\n g_OutFile File:WriteStr
; // OutLnToFile
BOOLEAN FUNCTION .Out?
OUTABLE IN aValue
: .OutToFile
if g_NeedOutLn then
begin
false >>> g_NeedOutLn
OutLnToFile
end // g_NeedOutLn
g_OutFile File:WriteStr
; // .OutToFile
VAR l_WasOut
VAR l_NeedIndent
PROCEDURE .OutValue
OUTABLE IN aValue
RULES
( aValue .IsValueValid ! )
()
( aValue IsArray )
begin
aValue .for> call.me
end // aValue IsArray
DEFAULT
begin
STRING VAR l_Value
aValue ToPrintable >>> l_Value
if ( l_WasOut ! ) then
begin
true >>> l_WasOut
IndentStr .OutToFile
false >>> l_NeedIndent
end // l_WasOut !
if ( l_NeedIndent ) then
begin
false >>> l_NeedIndent
IndentStr .OutToFile
end // l_NeedIndent
if ( l_Value \n == ) then
begin
l_Value .OutToFile
true >>> l_NeedIndent
end // ( l_Value \n == )
else
begin
l_Value .OutToFile
end // ( l_Value \n == )
end // DEFAULT
; // RULES
; // .OutValue
false >>> l_WasOut
false >>> l_NeedIndent
aValue .OutValue
if l_WasOut then
if g_EnableAutoEOL then
OutLnToFile
l_WasOut >>> Result
; // .Out?
: .Out
.Out? DROP
; // .Out
PROCEDURE Indented:
^ IN aLambda
TF g_Indent (
g_Indent cIndentChar Cat >>> g_Indent
aLambda DO
)
; // Indented:
USES
axiom:SysUtils
;
USES
arrays.ms.dict
;
USES
IsNil.ms.dict
;
TtfwWord FUNCTION .FindMemberRecur
STRING IN aName
TtfwWord IN aGen
TtfwKeyWord VAR l_Member
aName aGen pop:Word:FindMember >>> l_Member
if ( l_Member .IsNil ) then
( nil >>> Result )
else
( l_Member pop:KeyWord:Word >>> Result )
if ( Result .IsNil ) then
(
aGen .Inherited.Words .for> (
IN anItem
VAR l_Found
aName anItem call.me >>> l_Found
( Result .IsNil )
OR ( l_Found .IsNil )
OR ( Result = l_Found )
?ASSURE [ 'Multiply inheritance. Word: ' aName ' generator ' aGen .WordName ' parent generator ' anItem .WordName ]
l_Found >>> Result
)
)
; // .FindMemberRecur
ARRAY CompileTime-VAR g_GeneratedFiles []
%REMARK 'Ранее сгенерированные файлы'
TtfwWord VAR g_CurrentGenerator
%REMARK 'Текущий генератор'
: WithGen:
^ IN aGen
^ IN aLambda
TF g_CurrentGenerator (
aGen >>> g_CurrentGenerator
aLambda DO
) // TF g_CurrentGenerator
; // WithGen:
WordAlias .All .True
%REMARK 'Функтор определяющий, что все значения подходят.'
WordAlias GenCached: CacheMethod
%REMARK 'Кеширует значение учитывая текущий генератор. Пока определено как Cached:'
: .?
^ IN aWord
VAR l_Word
aWord |N g_CurrentGenerator .FindMemberRecur >>> l_Word
if ( l_Word .IsNil ) then
( aWord DO )
else
( l_Word DO )
; // .?
STRING FUNCTION Ext
'.dump' >>> Result
; // Ext
PROCEDURE ForceDirectories
STRING IN aPath
aPath sysutils:ForceDirectories ?ASSURE [ 'Не удалось создать директорию ' aPath ]
; // ForceDirectories
FILE FUNCTION TryOpen:
STRING IN aFileName
^ IN aOpenLambda
%SUMMARY
'Открывает файл aFileName методом aOpenLambda обрабатывая ошибки открытия.'
'Пытается открыть файл повторно несколько раз.'
;
VAR l_TryCount
20 >>> l_TryCount
while ( l_TryCount > 0 )
begin
TRY
aFileName aOpenLambda DO >>> Result
0 >>> l_TryCount
EXCEPT
Dec l_TryCount
nil >>> Result
if ( l_TryCount 0 == ) then
RAISE
else
begin
[ 'Файл ' aFileName ' был занят. Ожидаем его освобождения. Попытка номер: ' l_TryCount IntToStr ] strings:Cat >>std::out
500 SLEEP
end // ( l_TryCount 0 == )
END // TRY..EXCEPT
end // ( l_TryCount > 0 )
; // TryOpen:
FILE FUNCTION MakePathAndOpenWrite
STRING IN aFileName
%SUMMARY
'Открывает файл aFileName на запись.'
'Если надо - создаёт полный путь на файловой системе.'
;
aFileName sysutils:ExtractFilePath ForceDirectories
aFileName TryOpen: File:OpenWrite >>> Result
; // MakePathAndOpenWrite
CONST cRoot 'w:'
PROCEDURE BackupFile
STRING IN aFileName
VAR l_To
aFileName >>> l_To
l_To cRoot 'W:' string:Replace >>> l_To
l_To 'W:' 'C:\Temp\GenBackup' string:Replace >>> l_To
if ( aFileName sysutils:FileExists ) then
begin
$20 l_To aFileName CopyFile
end // ( aFileName sysutils:FileExists )
else
begin
FILE VAR l_In
l_To MakePathAndOpenWrite >>> l_In
// - делаем пустышку
TRY
FINALLY
nil >>> l_In
END // TRY..FINALLY
end // ( aFileName sysutils:FileExists )
; // BackupFile
PROCEDURE CopyChangedFile
STRING IN aTo
STRING IN aFrom
BOOLEAN IN aNeedBackup
aTo .NotIsNil ?ASSURE aFrom
aFrom .NotIsNil ?ASSURE aTo
if (
( aTo sysutils:FileExists ! )
OR ( cEmptyStr aTo aFrom CompareFiles ! )
) then
begin
if aNeedBackup then
begin
aTo BackupFile
end // aNeedBackup
$20 aTo aFrom CopyFile
end
; // CopyChangedFile
STRING elem_func FinalFileNamePrim
cEmptyStr >>> Result
; // FinalFileNamePrim
STRING FUNCTION .CutSuffix
STRING IN aString
STRING IN aSuffix
RULES
( aString .IsNil )
''
( aSuffix .IsNil )
aString
DEFAULT
begin
aString >>> Result
if ( aSuffix Result EndsStr ) then
begin
Result string:Len aSuffix string:Len -
0
Result
string:Substring >>> Result
end // ( aSuffix Result EndsStr )
Result
end // DEFAULT
; // RULES
>>> Result
; // .CutSuffix
STRING FUNCTION .CutPrefix
STRING IN aString
STRING IN aPrefix
RULES
( aString .IsNil )
''
( aPrefix .IsNil )
aString
DEFAULT
begin
aString >>> Result
if ( aPrefix Result StartsStr ) then
begin
Result string:Len aPrefix string:Len -
aPrefix string:Len
Result
string:Substring >>> Result
end // ( aPrefix Result StartsStr )
Result
end // DEFAULT
; // RULES
>>> Result
; // .CutPrefix
USES
CountIt.ms.dict
;
STRING elem_func LUID
VAR l_UID
Self .UID >>> l_UID
RULES
DEFAULT
l_UID
; // RULES
>>> Result
; // LUID
BOOLEAN elem_func IsSameModelElement
ModelElement IN anOther
RULES
( Self anOther ?== )
true
( Self .LUID anOther .LUID == )
true
DEFAULT
false
; // RULES
>>> Result
; // IsSameModelElement
BOOLEAN elem_func IsArray
Self .IsStereotype st_Vector >>> Result
; // IsArray
BOOLEAN elem_func IsOpenArray
Self .IsArray
AND ( Self .GetUP "array type" 'open' == )
>>> Result
; // IsOpenArray
USES
FirstElement.ms.dict
;
ModelElement elem_func FirstAttribute
Cached:
(
Self .Attributes .FirstElement
)
>>> Result
; // FirstAttribute
BOOLEAN elem_func IsMixInParamType
Self .IsStereotype st_ImpurityParamType
>>> Result
; // IsMixInParamType
: g_MixInParamTypes
@SELF
; // g_MixInParamTypes
BOOLEAN elem_func IsIterator
Self .IsStereotype st_Iterator >>> Result
; // IsIterator
FORWARD .IteratorAction
STRING elem_func TypeName
Cached:
(
RULES
( Self .IsNil )
''
( Self IsString )
Self
( Self .IsOpenArray )
( [ 'array of ' Self .FirstAttribute .Target call.me ] strings:Cat )
( Self .IsIterator )
( Self .IteratorAction call.me )
DEFAULT
(
STRING VAR l_ExtName
Self .GetUP 'extprop:pas:TypeName' >>> l_ExtName
RULES
( l_ExtName .IsNotNil )
l_ExtName
DEFAULT
( Self .Name )
; // RULES
)
; // RULES
)
>>> Result
if ( Self .IsMixInParamType ) then
begin
VAR l_Field
@ g_MixInParamTypes %% ( Self .Name ) >>> l_Field
if ( l_Field .IsNotNil ) then
begin
l_Field DO >>> l_Field
if ( l_Field .IsNotNil ) then
begin
l_Field call.me >>> Result
end // ( l_Field .IsNotNil )
end // ( l_Field .IsNotNil )
end // ( Self .IsMixInParamType )
; // TypeName
BOOLEAN elem_func IsSameType
ModelElement IN anOther
RULES
( Self anOther .IsSameModelElement )
true
( Self IsString )
RULES
( anOther IsString )
false
DEFAULT
( Self anOther .TypeName == )
; // RULES
( anOther IsString )
RULES
( Self IsString )
false
DEFAULT
( Self .TypeName anOther == )
; // RULES
( Self .TypeName anOther .TypeName == )
true
DEFAULT
false
; // RULES
>>> Result
; // IsSameType
USES
GarantModel.ms.dict
;
BOOLEAN elem_func IsScriptKeyword
Self .IsStereotype st_ScriptKeyword
>>> Result
; // IsScriptKeyword
WordAlias [[ [
%REMARK 'Начинает определение константного массива. Пока просто мапируется на неконстантный.'
WordAlias ]] ]
%REMARK 'Заканчивает определение константного массива. Пока просто мапируется на неконстантный.'
USES
axiom:WordBox
;
ModelElement elem_func WeakRef
%SUMMARY
'Возвращает СЛАБУЮ ссылку на элемент.'
;
RULES
( Self IsIntf )
( Self pop:WordBox:Boxed )
DEFAULT
Self
; // RULES
>>> Result
; // WeakRef
ARRAY elem_func ElementToArray
RULES
( Self .IsNil )
[empty]
DEFAULT
begin
Cached:
(
[[ Self .WeakRef ]]
)
end // DEFAULT
; // RULES
>>> Result
; // ElementToArray
WordAlias .ToArray .ElementToArray
ARRAY elem_func ElementToArray:
^ IN aLambda
Self aLambda DO .ElementToArray
>>> Result
; // ElementToArray:
WordAlias .ToArray: .ElementToArray:
ARRAY FUNCTION ToArray:
^ IN Self
VAR l_Value
Self DO >>> l_Value
RULES
( l_Value IsIntf )
[[ l_Value ]]
DEFAULT
( l_Value .ToArray )
; // RULES
>>> Result
; // ToArray:
elem_iterator InheritsEx
Cached:
(
VAR l_Inherits
Self .Inherits >>> l_Inherits
RULES
( l_Inherits .IsEmpty )
RULES
( Self .IsScriptKeyword )
( ToArray: GarantModel::TtfwRegisterableWord )
DEFAULT
[empty]
; // RULES
DEFAULT
l_Inherits
; // RULES
)
>>> Result
; // InheritsEx
BOOLEAN elem_func InheritsFrom
ModelElement IN anAncestor
anAncestor :Cached:
(
RULES
( Self .IsNil )
false
( Self anAncestor .IsSameType )
true
(
Self .InheritsEx
.filter> ( anAncestor call.me )
.NotEmpty
)
true
DEFAULT
false
; // RULES
)
>>> Result
; // InheritsFrom
USES
UseNewGenExcluded.ms.dict
;
BOOLEAN elem_func IsControllerInterfaces
( Self .IsStereotype st_ControllerInterfaces )
>>> Result
; // IsControllerInterfaces
USES
ForceUseNewGen.ms.dict
;
BOOLEAN elem_func IsScriptKeywordsPack
Self .IsStereotype st_ScriptKeywordsPack
>>> Result
; // IsScriptKeywordsPack
BOOLEAN elem_func IsUtilityPack
Cached:
(
RULES
( Self .IsStereotype st_UtilityPack )
true
( Self .IsScriptKeywordsPack )
true
DEFAULT
false
; // RULES
)
>>> Result
; // IsUtilityPack
BOOLEAN elem_func UseNewGenExcluded
RULES
( Self .IsControllerInterfaces )
true
( Self GarantModel::vcmData .InheritsFrom )
true
(
( Self .IsUtilityPack ! )
AND ( Self GarantModel::Tl3Tag .InheritsFrom )
//( Self GarantModel::Tl3Variant .InheritsFrom )
//AND ( Self GarantModel::Tl3TagImpl .InheritsFrom ! )
AND ( Self GarantModel::TtfwKeyWordPrim .InheritsFrom ! )
)
true
( Self GarantModel::TddComboBoxConfigItem .InheritsFrom )
true
( Self GarantModel::Tl3ProtoObjectForTie ?== )
false
( Self GarantModel::Tl3ProtoObjectForTie .InheritsFrom )
true
( Self GarantModel::evdTagHolder .InheritsFrom )
true
DEFAULT
begin
if ( g_UseNewGenExcluded .IsNil ) then
Init_g_UseNewGenExcluded
g_UseNewGenExcluded .IsNil ?FAIL 'Не инициализирован g_UseNewGenExcluded'
g_UseNewGenExcluded
.filter> ( Self .LUID == )
.NotEmpty
end // DEFAULT
; // RULES
>>> Result
; // UseNewGenExcluded
CONST cNotFinished 'NOT_FINISHED_'
CONST cNotCompleted 'NOT_COMPLETED_'
STRING FUNCTION .CutFinished
STRING IN Self
Self
cNotFinished .CutPrefix
cNotCompleted .CutPrefix
>>> Result
; // .CutFinished
STRING elem_func CustomFinalFileName
BOOLEAN IN aForCopy
Self .? .FinalFileNamePrim >>> Result
if ( Result .IsNotNil ) then
begin
Result '\' .CutPrefix >>> Result
[ cRoot
// - это потому, что в пути нету диска, а для ExtractFileName он нужен
Result ] cPathSep strings:CatSep >>> Result
end // ( Result .IsNotNil )
if ( Result .IsNotNil ) then
begin
if aForCopy then
if ( Self .UseNewGenExcluded ) then
begin
VAR l_Path
VAR l_Name
Result sysutils:ExtractFilePath >>> l_Path
Result sysutils:ExtractFileName >>> l_Name
l_Name .CutFinished
>>> l_Name
cNotCompleted l_Name Cat
>>> l_Name
l_Path l_Name Cat >>> Result
end // (Self .UseNewGenExcluded )
end // ( Result .IsNotNil )
; // CustomFinalFileName
STRING elem_func FinalFileName
Self true .CustomFinalFileName
>>> Result
; // FinalFileName
STRING CompileTime-VAR g_TempFileName ''
STRING CompileTime-VAR g_RealFileName ''
STRING CompileTime-VAR g_FinalFileName ''
STRING CompileTime-VAR g_FinalFileNameForUC ''
BOOLEAN CompileTime-VAR g_UCRead false
ModelElement CompileTime-VAR g_CurrentGeneratedElement nil
CONST cGenScriptsFolder 'W:\common\GenScripts\'
BOOLEAN elem_func CanCopyToFinalFile
false >>> Result
; // CanCopyToFinalFile
PROCEDURE DoDeleteFile
STRING IN aFileName
BOOLEAN IN aNeedBackup
if aNeedBackup then
begin
aFileName BackupFile
end // aNeedBackup
aFileName DeleteFile DROP
; // DoDeleteFile
elem_proc GenerateWordToFileWith:
^ IN aLambda
TF g_Indent (
'' >>> g_Indent
STRING VAR l_FileName
[ Self .WordName .? Ext ] strings:Cat >>> l_FileName
STRING VAR l_TempPath
'C:\Temp\GenScripts\' >>> l_TempPath
l_TempPath ForceDirectories
STRING VAR l_RealPath
cGenScriptsFolder >>> l_RealPath
l_RealPath ForceDirectories
TF g_TempFileName (
[ l_TempPath l_FileName ] cPathSep strings:CatSep >>> g_TempFileName
TF g_RealFileName (
[ l_RealPath l_FileName ] cPathSep strings:CatSep >>> g_RealFileName
if ( g_TempFileName .TextNotInArray: g_GeneratedFiles ) then
begin
g_TempFileName .AddToArray: g_GeneratedFiles
TF g_FinalFileName (
TF g_FinalFileNameForUC (
Self .FinalFileName >>> g_FinalFileName
Self false .CustomFinalFileName >>> g_FinalFileNameForUC
TF g_OutFile (
g_TempFileName MakePathAndOpenWrite >>> g_OutFile
TF g_UCRead (
TF g_NeedOutLn (
TF g_CurrentGeneratedElement (
Self >>> g_CurrentGeneratedElement
Self aLambda DO
)
) // TF g_NeedOutLn
) // TF g_UCRead
) // TF g_OutFile
g_RealFileName g_TempFileName false CopyChangedFile
if ( g_FinalFileName .IsNotNil ) then
begin
if ( Self .? .CanCopyToFinalFile ) then
begin
g_FinalFileName g_TempFileName true CopyChangedFile
VAR l_Path
VAR l_Name
g_FinalFileName sysutils:ExtractFilePath >>> l_Path
g_FinalFileName sysutils:ExtractFileName >>> l_Name
VAR l_NameToDelete
VAR l_FileToDelete
if ( cNotCompleted l_Name StartsStr ! ) then
begin
l_Name cNotFinished .CutPrefix >>> l_NameToDelete
[ l_Path cNotCompleted l_NameToDelete ] strings:Cat >>> l_FileToDelete
if ( l_FileToDelete g_FinalFileName SameText ! ) then
begin
if ( l_FileToDelete sysutils:FileExists ) then
begin
l_FileToDelete true DoDeleteFile
end // ( l_FileToDelete sysutils:FileExists )
end // ( l_FileToDelete g_FinalFileName SameText ! )
end // ( cNotCompleted l_Name StartsStr ! )
if ( cNotFinished l_Name StartsStr ! ) then
begin
l_Name cNotCompleted .CutPrefix >>> l_NameToDelete
[ l_Path cNotFinished l_NameToDelete ] strings:Cat >>> l_FileToDelete
if ( l_FileToDelete g_FinalFileName SameText ! ) then
begin
if ( l_FileToDelete sysutils:FileExists ) then
begin
l_FileToDelete true DoDeleteFile
end // ( l_FileToDelete sysutils:FileExists )
end // ( l_FileToDelete g_FinalFileName SameText ! )
end // ( cNotFinished l_Name StartsStr ! )
end // ( Self .? .CanCopyToFinalFile )
end // ( g_FinalFileName .IsNotNil )
) // TF g_FinalFileNameForUC
) // TF g_FinalFileName
end // g_TempFileName .TextNotInArray: g_GeneratedFiles
) // TF g_RealFileName
) // TF g_TempFileName
) // TF g_Indent
; // GenerateWordToFileWith:
elem_proc DeleteWordFile
STRING VAR l_FileName
[ Self .WordName .? Ext ] strings:Cat >>> l_FileName
STRING VAR l_RealPath
cGenScriptsFolder >>> l_RealPath
TF g_RealFileName (
[ l_RealPath l_FileName ] cPathSep strings:CatSep >>> g_RealFileName
if ( g_RealFileName sysutils:FileExists ) then
begin
g_RealFileName true DoDeleteFile
end // ( g_RealFileName sysutils:FileExists )
) // TF g_RealFileName
; // DeleteWordFile
BOOLEAN elem_func IsServiceImplementation
Self .IsStereotype st_ServiceImplementation
>>> Result
; // IsServiceImplementation
BOOLEAN elem_func IsService
Self .IsStereotype st_Service
>>> Result
; // IsService
BOOLEAN elem_func IsTestCase
Self .IsStereotype st_TestCase
>>> Result
; // IsTestCase
BOOLEAN elem_func IsTestLibrary
Self .IsStereotype st_TestLibrary
>>> Result
; // IsTestLibrary
BOOLEAN elem_func IsTestUnit
Self .IsStereotype st_TestUnit
>>> Result
; // IsTestUnit
BOOLEAN elem_func IsUnit
Self .IsStereotype st_Unit
>>> Result
; // IsUnit
BOOLEAN elem_func IsImpl
Self .IsStereotype st_Impl
>>> Result
; // IsImpl
BOOLEAN elem_func IsLibrary
Self .IsStereotype st_Library
>>> Result
; // IsLibrary
BOOLEAN elem_func IsVCMModule
Self .IsStereotype st_VCMModule
>>> Result
; // IsVCMModule
BOOLEAN elem_func IsVCMCustomForm
Self .IsStereotype st_VCMCustomForm
>>> Result
; // IsVCMCustomForm
BOOLEAN elem_func IsVCMDataModule
Self .IsStereotype st_VCMDataModule
>>> Result
; // IsVCMDataModule
BOOLEAN elem_func IsVCMForm
Self .IsStereotype st_VCMForm
>>> Result
; // IsVCMForm
BOOLEAN elem_func IsVCMContainer
Self .IsStereotype st_VCMContainer
>>> Result
; // IsVCMContainer
BOOLEAN elem_func IsVCMMainForm
Self .IsStereotype st_VCMMainForm
>>> Result
; // IsVCMMainForm
BOOLEAN elem_func IsGuiControl
Self .IsStereotype st_GuiControl
>>> Result
; //IsGuiControl
BOOLEAN elem_func IsUseCaseController
Self .IsStereotype st_UseCaseController
>>> Result
; // IsUseCaseController
BOOLEAN elem_func IsViewAreaController
Self .IsStereotype st_ViewAreaController
>>> Result
; // IsViewAreaController
BOOLEAN elem_func IsUseCaseControllerImp
Self .IsStereotype st_UseCaseControllerImp
>>> Result
; // IsUseCaseControllerImp
BOOLEAN elem_func IsViewAreaControllerImp
Self .IsStereotype st_ViewAreaControllerImp
>>> Result
; // IsViewAreaControllerImp
BOOLEAN elem_func IsSimpleClass
Cached:
(
RULES
( Self .IsUseCaseControllerImp )
( Self .Abstraction at_abstract != )
( Self .IsViewAreaControllerImp )
( Self .Abstraction at_abstract != )
( Self .IsStereotype st_SimpleClass )
true
( Self .IsStereotype st_ObjStub )
true
( Self .IsService )
true
( Self .IsServiceImplementation )
true
( Self .IsScriptKeyword )
true
( Self .IsTestCase )
true
( Self .IsGuiControl )
true
( Self .IsVCMForm )
true
( Self .IsStereotype st_VCMFinalForm )
true
( Self .IsVCMContainer )
true
( Self .IsStereotype st_VCMFinalContainer )
true
DEFAULT
false
; // RULES
)
>>> Result
; // IsSimpleClass
BOOLEAN elem_func IsInternalInterfaces
Self .IsStereotype st_InternalInterfaces
>>> Result
; // IsInternalInterfaces
BOOLEAN elem_func IsInterfaces
Cached:
(
RULES
( Self .IsStereotype st_Interfaces )
true
( Self .IsInternalInterfaces )
true
DEFAULT
false
; // RULES
)
>>> Result
; // IsInterfaces
: .SecondElement
ARRAY IN anArray
ModelElement VAR l_Found
nil >>> l_Found
INTEGER VAR l_Index
0 >>> l_Index
anArray .trunc> ( DROP l_Index < 2 ) .for> (
IN anItem
( l_Index 1 == ) ?
( anItem >>> l_Found )
INC l_Index
) // anArray .trunc> ( DROP l_Index < 2 ) .for>
l_Found
; // .SecondElement
ModelElement CompileTime-VAR g_DefaultInterfaceAncestor nil
BOOLEAN elem_func IsTypedef
Self .IsStereotype st_Typedef
>>> Result
; // IsTypedef
BOOLEAN elem_func IsPointer
Self .UPisTrue "isPointer"
>>> Result
; // IsPointer
ModelElement elem_func MainAncestorPrim
Self .InheritsEx .FirstElement
>>> Result
; // MainAncestorPrim
BOOLEAN elem_func IsInterface
Cached:
(
RULES
( Self .IsStereotype st_ObjStub )
false
( Self .IsStereotype st_Facet )
true
( Self .IsStereotype st_Interface )
true
( Self .Name 'object' == )
true
( Self .IsTypedef )
RULES
( Self .IsPointer )
false
DEFAULT
( Self .MainAncestorPrim call.me )
; // RULES
DEFAULT
false
; // RULES
)
>>> Result
; // IsInterface
BOOLEAN elem_func IsPureMixIn
Self .IsStereotype st_PureMixIn
>>> Result
; // IsPureMixIn
BOOLEAN elem_func IsTestCaseMixIn
Self .IsStereotype st_TestCaseMixIn
>>> Result
; // IsTestCaseMixIn
BOOLEAN elem_func IsMixIn
Cached:
(
RULES
( Self .IsStereotype st_Impurity )
true
( Self .IsTestCaseMixIn )
true
( Self .IsVCMCustomForm )
RULES
( Self .Abstraction at_abstract == )
RULES
( Self .MainAncestorPrim .IsNil )
true
( Self .MainAncestorPrim call.me )
true
DEFAULT
false
; // RULES
DEFAULT
false
; // RULES
/*{ ( Self .IsUseCaseController )
( Self .Abstraction at_abstract == )
( Self .IsViewAreaController )
( Self .Abstraction at_abstract == )}*/
( Self .IsUseCaseControllerImp )
( Self .Abstraction at_abstract == )
( Self .IsViewAreaControllerImp )
( Self .Abstraction at_abstract == )
DEFAULT
false
; // RULES
)
>>> Result
; // IsMixIn
BOOLEAN elem_func IsVCMFormSetFactory
Self .IsStereotype st_VCMFormSetFactory
>>> Result
; // IsVCMFormSetFactory
BOOLEAN elem_func IsVCMFormsPack
Self .IsStereotype st_VCMFormsPack
>>> Result
; // IsVCMFormsPack
ModelElement elem_func DefaultAncestor
Cached:
(
RULES
( Self .IsMixIn )
nil
( Self .IsVCMFormSetFactory )
GarantModel::TvcmFormSetFactory
( Self .IsVCMFormsPack )
GarantModel::TvcmModule
( Self .IsVCMContainer )
GarantModel::TvcmContainerForm
( Self .IsVCMMainForm )
GarantModel::TvcmMainForm
( Self .IsVCMDataModule )
GarantModel::TDataModule
( Self .IsVCMCustomForm )
GarantModel::TvcmEntityForm
( Self .Abstraction at_abstract == )
nil
( Self .IsViewAreaController )
GarantModel::IvcmViewAreaController
( Self .IsUseCaseController )
GarantModel::IvcmUseCaseController
DEFAULT
nil
; // RULES
)
>>> Result
; // DefaultAncestor
ModelElement elem_func MainAncestor
Cached:
(
RULES
( Self .IsPointer )
( Self .MainAncestorPrim )
( Self .IsTypedef )
( Self .MainAncestorPrim )
( Self .IsPureMixIn )
( Self .MainAncestorPrim )
( Self .IsInterface )
(
RULES
(
( g_DefaultInterfaceAncestor .IsNotNil )
AND ( g_DefaultInterfaceAncestor Self != )
AND ( Self .MainAncestorPrim .IsNil )
)
g_DefaultInterfaceAncestor
DEFAULT
( Self .MainAncestorPrim )
; // RULES
)
DEFAULT
( Self .MainAncestorPrim )
; // RULES
>>> Result
RULES
( Result .IsNil )
( Self .DefaultAncestor )
DEFAULT
Result
; // RULES
)
>>> Result
; // MainAncestor
BOOLEAN elem_func IsRange
Self .IsStereotype st_Range
>>> Result
; // IsRange
BOOLEAN elem_func IsEnum
Self .IsStereotype st_Enum
>>> Result
; // IsEnum
BOOLEAN elem_func IsFunction
Self .IsStereotype st_Function
>>> Result
; // IsFunction
BOOLEAN elem_func IsRecord
RULES
( Self .IsStereotype st_Struct )
true
( Self .IsTypedef )
RULES
( Self .IsPointer )
false
DEFAULT
( Self .MainAncestor call.me )
; // RULES
DEFAULT
false
; // RULES
>>> Result
; // IsRecord
BOOLEAN elem_func IsDefine
Self .IsStereotype st_Define
>>> Result
; // IsDefine
BOOLEAN elem_func IsUndef
Self .IsStereotype st_Undef
>>> Result
; // IsUndef
BOOLEAN elem_func IsUnion
Self .IsStereotype st_Union
>>> Result
; // IsUnion
BOOLEAN elem_func IsRecordOrUnion
RULES
( Self .IsRecord )
true
( Self .IsUnion )
true
DEFAULT
false
; // RULES
>>> Result
; // IsRecordOrUnion
BOOLEAN elem_func IsStaticObject
Self .IsStereotype st_StaticObject
>>> Result
; // IsStaticObject
BOOLEAN elem_func IsRecordOrUnionOrStaticObject
RULES
( Self .IsRecordOrUnion )
true
( Self .IsStaticObject )
true
DEFAULT
false
; // RULES
>>> Result
; // IsRecordOrUnionOrStaticObject
BOOLEAN elem_func CannotFinalizeProperty
RULES
( Self .IsRecordOrUnionOrStaticObject )
true
( Self .IsMixInParamType )
true
( Self .IsOpenArray )
false
( Self .IsArray )
true
DEFAULT
false
; // RULES
>>> Result
; // CannotFinalizeProperty
BOOLEAN elem_func IsElementProxy
Self .IsStereotype st_ElementProxy
>>> Result
; // IsElementProxy
BOOLEAN elem_func IsSetOf
Self .IsStereotype st_SetOf
>>> Result
; // IsSetOf
BOOLEAN elem_func IsException
Self .IsStereotype st_Exception
>>> Result
; // IsException
BOOLEAN elem_func IsTagTable
Self .IsStereotype st_TagTable
>>> Result
; // IsTagTable
BOOLEAN elem_func IsVCMGUI
Self .IsStereotype st_VCMGUI
>>> Result
; // IsVCMGUI
BOOLEAN elem_func IsTestTarget
Self .IsStereotype st_TestTarget
>>> Result
; // IsTestTarget
BOOLEAN elem_func IsVCMUseCaseRealization
Self .IsStereotype st_VCMUseCaseRealization
>>> Result
; // IsVCMUseCaseRealization
BOOLEAN elem_func IsVCMUseCase
Self .IsStereotype st_VCMUseCase
>>> Result
; // IsVCMUseCase
BOOLEAN elem_func IsVCMTestTarget
Self .IsStereotype st_VCMTestTarget
>>> Result
; // IsVCMTestTarget
BOOLEAN elem_func IsExeTarget
Self .IsStereotype st_ExeTarget
>>> Result
; // IsExeTarget
BOOLEAN elem_func IsExe
RULES
( Self .IsExeTarget )
true
( Self .IsTestTarget )
true
( Self .IsVCMGUI )
true
DEFAULT
false
; // RULES
>>> Result
; // IsExe
BOOLEAN elem_func IsAdapterTarget
Self .IsStereotype st_AdapterTarget >>> Result
; // IsAdapterTarget
BOOLEAN elem_func IsDLL
Self .IsAdapterTarget >>> Result
; // IsDLL
BOOLEAN elem_func IsTarget
Cached:
(
RULES
( Self .IsVCMGUI )
true
( Self .IsExe )
true
( Self .IsDLL )
true
DEFAULT
false
; // RULES
)
>>> Result
; // IsTarget
BOOLEAN elem_func IsAtom
Self .IsStereotype st_Atom
>>> Result
; // IsAtom
BOOLEAN elem_func IsTag
Self .IsStereotype st_Tag
>>> Result
; // IsTag
BOOLEAN elem_func IsEvdSchemaElement
Self .IsAtom
>>> Result
; // IsEvdSchemaElement
BOOLEAN elem_func IsClassOrMixIn
Cached:
(
RULES
( Self .IsSimpleClass )
true
( Self .IsMixIn )
true
DEFAULT
false
; // RULES
)
>>> Result
; // IsClassOrMixIn
BOOLEAN elem_func IsTestClass
Self .IsStereotype st_TestClass >>> Result
; // IsTestClass
BOOLEAN elem_func IsUserType
Self .IsStereotype st_UserType >>> Result
; // IsUserType
BOOLEAN elem_func IsScriptKeywords
Self .IsStereotype st_ScriptKeywords >>> Result
; // IsScriptKeywords
BOOLEAN elem_func IsTestResults
Self .IsStereotype st_TestResults >>> Result
; // IsTestResults
BOOLEAN elem_func NeedOwnFilePrim
Cached:
(
RULES
( Self .IsNil )
false
( Self .IsScriptKeywords )
false
( Self .IsUserType )
true
( Self .IsTestClass )
true
( Self .IsEvdSchemaElement )
true
( Self .IsTarget )
true
( Self .IsTestResults )
true
( Self .IsTagTable )
true
( Self .IsInterfaces )
true
( Self .IsUtilityPack )
true
( Self .IsMixIn )
true
( Self .IsElementProxy )
true
( Self .IsVCMFormSetFactory )
true
( Self .IsVCMCustomForm )
true
( Self .IsTestLibrary )
RULES
( Self .FinalFileName .IsNil )
false
DEFAULT
true
; // RULES
( Self .IsTestUnit )
true
( Self .IsUnit )
false
( Self .IsImpl )
false
( Self .IsLibrary )
false
( Self .IsSimpleClass )
begin
RULES
( Self .Visibility ProtectedAccess == )
false
( Self .Visibility PrivateAccess == )
RULES
( Self .IsScriptKeyword )
RULES
( Self .Parent .IsVCMModule )
true
DEFAULT
false
; // RULES
DEFAULT
false
; // RULES
DEFAULT
(
ModelElement VAR l_Parent
Self .Parent >>> l_Parent
RULES
(
l_Parent .IsScriptKeywordsPack
AND ( Self .IsScriptKeyword )
)
true
( l_Parent .IsClassOrMixIn )
false
( l_Parent .IsUtilityPack )
false
( l_Parent .IsInterfaces )
false
DEFAULT
true
; // RULES
)
; // RULES
end // ( Self .IsSimpleClass )
DEFAULT
false
; // RULES
)
>>> Result
; // NeedOwnFilePrim
elem_proc CurrentGenerator
Self g_CurrentGenerator DO
; // CurrentGenerator
USES
CallInherited.ms.dict
;
USES
classRelations.ms.dict
;
BOOLEAN elem_func NeedOwnFile
Self .? .NeedOwnFilePrim >>> Result
; // NeedOwnFile
PROCEDURE OutLn
if g_NeedOutLn then
OutLnToFile
true >>> g_NeedOutLn
; // OutLn
elem: WithDelim
STRING IN aDelim
TtfwWord IN aVar
TtfwWord IN aLambda
[
if ( aVar DO ! ) then
begin
true aVar pop:Word:SetValue
end
else
begin
aDelim
end
Self
] aLambda DO
; // WithDelim
elem: WithComma:
^ IN aVar
^ IN aLambda
Self ', ' aVar aLambda .WithDelim
; // WithComma:
STRING FUNCTION .CutT
STRING IN aName
aName 'T' .CutPrefix >>> Result
; // .CutT
CONST cProxy '_Proxy'
STRING elem_func UnitNamePrim
GenCached:
(
STRING VAR l_Path
Self .FinalFileName >>> l_Path
RULES
( l_Path .IsNotNil )
( l_Path sysutils:ExtractFileName cEmptyStr sysutils:ChangeFileExt )
( Self .IsNil )
cEmptyStr
( Self .IsElementProxy )
( Self .Name cProxy Cat )
( Self .IsTagTable )
( Self .Name '_Schema' Cat )
( Self .IsScriptKeyword )
( Self .Name .CutT )
( Self .IsSimpleClass )
( Self .Name .CutT )
DEFAULT
( Self .Name )
; // RULES
>>> Result
if ( Self .UseNewGenExcluded ) then
begin
Result
.CutFinished
>>> Result
cNotCompleted Result Cat
>>> Result
end // ( Self .UseNewGenExcluded )
Result
)
>>> Result
; // UnitNamePrim
STRING elem_func UnitName
GenCached:
(
Self .UnitNamePrim .CutFinished
)
>>> Result
; // UnitName
ModelElement elem_func UnitProducer
GenCached:
(
RULES
( Self .IsNil )
nil
( Self IsString )
Self
( Self .NeedOwnFile )
Self
DEFAULT
( Self .Parent call.me )
; // RULES
)
>>> Result
; // UnitProducer
STRING elem_func EffectiveUnitName
GenCached:
(
Self .UnitProducer .UnitName
)
>>> Result
; // EffectiveUnitName
ARRAY FUNCTION .filterNil>
ARRAY IN anArray
anArray
.filter> .IsNotNil
>>> Result
; // .filterNil>
ARRAY FUNCTION .filterMixIns>
ARRAY IN anArray
anArray
.filter> ( .IsMixIn ! )
// .filter> ( .IsPureMixIn ! )
>>> Result
; // .filterMixIns>
BOOLEAN elem_func IsMethod
Self .IsStereotype st_method >>> Result
; // IsMethod
BOOLEAN elem_func IsMessageOperation
Self .IsStereotype st_message::Operation >>> Result
; // IsMessageOperation
BOOLEAN elem_func IsMessage
Self .IsStereotype st_Message >>> Result
; // IsMessage
BOOLEAN elem_func IsLocalMethod
Self .IsStereotype st_localmethod >>> Result
; // IsLocalMethod
ModelElement elem_func KeywordOperation
Self .SpelledFor
>>> Result
; // KeywordOperation
ModelElement elem_func KeywordImplementationMethod
Self .Stub
>>> Result
; // KeywordImplementationMethod
ModelElement elem_func KeywordObjectToOperate
Self .Speller
>>> Result
; // KeywordObjectToOperate
BOOLEAN elem_func IsKeyWord
Self .IsStereotype st_keyword::Operation
>>> Result
; // IsKeyWord
BOOLEAN elem_func IsGlobalKeyWord
Self .IsStereotype st_globalkeyword::Operation
>>> Result
; // IsGlobalKeyWord
BOOLEAN elem_func IsSomeKeyWord
RULES
( Self .IsKeyWord )
true
( Self .IsGlobalKeyWord )
true
DEFAULT
false
; // RULES
>>> Result
; // IsSomeKeyWord
USES
axiom:CompiledProcedure
axiom:KeyValues
;
USES
KeyValuesCreateAndDo.ms.dict
;
elem: DecorateMethodAndDo:
^ IN aLambda
KeyValuesCreateAndDo: (
IN aMethod
aMethod -> Original := ( Self .WeakRef )
aMethod aLambda DO
) // KeyValuesCreateAndDo:
; // DecorateMethodAndDo:
INTERFACE elem_func DecorateMethod:
^ IN aLambda
Self .DecorateMethodAndDo: (
IN aMethod
aMethod pop:Word:Box >>> Result
aMethod aLambda DO
) // Self .DecorateMethodAndDo:
; // DecorateMethod:
INTERFACE FUNCTION MakeParam:
STRING IN aName
ModelElement IN aType
^ IN aLambda
KeyValuesCreateAndDo: (
IN l_Param
l_Param pop:Word:Box >>> Result
l_Param -> Name := aName
if ( aType .IsNotNil ) then
begin
l_Param -> Target := aType
end // ( aType .IsNotNil )
l_Param aLambda DO
) // KeyValuesCreateAndDo:
; // MakeParam:
INTERFACE FUNCTION MakeParam
STRING IN aName
ModelElement IN aType
aName aType MakeParam: DROP
>>> Result
; // MakeParam
WordAlias MakeFunction MakeParam
WordAlias MakeFunction: MakeParam:
WordAlias MakeField MakeParam
WordAlias MakeField: MakeParam:
WordAlias MakeProperty MakeParam
WordAlias MakeProperty: MakeParam:
: MakeProcedure
nil MakeFunction
; // MakeProcedure
MACRO MakeProcedure:
'nil' Ctx:Parser:PushSymbol
'MakeFunction:' Ctx:Parser:PushSymbol
; // MakeProcedure:
STRING elem_func SelfName
Self .GetUP 'extprop:rc:SelfName' >>> Result
if ( Result .IsNil ) then
begin
Self .TypeName >>> Result
end
else
begin
Result ToPrintable >>> Result
end // ( Result .IsNil )
; // SelfName
INTERFACE elem_func ValueParam
Cached:
(
'aValue' Self MakeParam
) >>> Result
; // ValueParam
BOOLEAN FUNCTION .HasSomeOf:
ARRAY IN anArray
^ IN aCompareFunc
anArray
.filter> ( aCompareFunc DO )
.NotEmpty
>>> Result
; // .HasSomeOf:
BOOLEAN elem_func HasName
STRING IN aName
Self .Name aName ==
>>> Result
; // HasName
BOOLEAN FUNCTION .HasModelElementWithName
ARRAY IN anArray
STRING IN aName
anArray .HasSomeOf: ( aName .HasName )
>>> Result
; // .HasModelElementWithName
ModelElement elem_func OpSelfParam
Cached:
(
'a' Self .SelfName Cat Self MakeParam
)
>>> Result
; // OpSelfParam
ModelElement elem_func CtxParam
Cached:
(
'aCtx' Self MakeParam
)
>>> Result
; // CtxParam
BOOLEAN elem_func IsCreator
Self .IsStereotype st_creator::Operation
>>> Result
; // IsCreator
BOOLEAN elem_func IsVarWorker
RULES
( Self .IsStereotype st_varworker::Operation )
true
( Self .IsStereotype st_globalvarworker::Operation )
true
DEFAULT
false
; // RULES
>>> Result
; // IsVarWorker
BOOLEAN elem_func IsWordWorker
RULES
( Self .IsStereotype st_wordworker::Operation )
true
( Self .IsStereotype st_globalwordworker::Operation )
true
DEFAULT
false
; // RULES
>>> Result
; // IsWordWorker
STRING elem_func NameForScript
Self .GetUP "NameForScript" ToPrintable
>>> Result
; // NameForScript
USES
string.ms.dict
;
STRING FUNCTION RemoveDuplicatedIfDef
STRING IN aValue
cEmptyStr >>> Result
ARRAY VAR l_Outed
[] >>> l_Outed
aValue ',' string:Split:for> (
IN aSubstr
aSubstr string:Trim >>> aSubstr
if ( aSubstr .IsNotNil )
if ( aSubstr .TextNotInArray: l_Outed ) then
begin
aSubstr .AddToArray: l_Outed
if ( Result .IsNil ) then
( aSubstr >>> Result )
else
( Result ',' aSubstr Cat Cat >>> Result )
end // ( aSubstr .TextNotInArray: l_Outed )
) // aValue ',' string:Split:for>
; // RemoveDuplicatedIfDef
ModelElement CompileTime-VAR g_Implementor nil
FORWARD .MainAncestorThatNotMixIn
STRING elem_func IfDefStr
Cached:
(
Self .GetUP "ifdef" >>> Result
VAR l_Parent
Self .Parent >>> l_Parent
if ( l_Parent .IsNotNil ) then
begin
VAR l_ParentIfDefStr
l_Parent call.me >>> l_ParentIfDefStr
if ( l_ParentIfDefStr .IsNotNil ) then
begin
if ( Result .IsNil ) then
begin
l_ParentIfDefStr >>> Result
end // ( Result .IsNil )
else
begin
l_ParentIfDefStr ',' Result Cat Cat >>> Result
end // ( Result .IsNil )
end // ( l_ParentIfDefStr .IsNotNil )
end // ( l_Parent .IsNotNil )
Result RemoveDuplicatedIfDef
)
>>> Result
; // IfDefStr
STRING elem_func IfNDefStr
Cached:
(
Self .GetUP "ifndef" >>> Result
VAR l_Parent
Self .Parent >>> l_Parent
if ( l_Parent .IsNotNil ) then
begin
VAR l_ParentIfDefStr
l_Parent call.me >>> l_ParentIfDefStr
if ( l_ParentIfDefStr .IsNotNil ) then
begin
if ( Result .IsNil ) then
begin
l_ParentIfDefStr >>> Result
end // ( Result .IsNil )
else
begin
l_ParentIfDefStr ',' Result Cat Cat >>> Result
end // ( Result .IsNil )
end // ( l_ParentIfDefStr .IsNotNil )
end // ( l_Parent .IsNotNil )
Result RemoveDuplicatedIfDef
)
>>> Result
; // IfNDefStr
BOOLEAN elem_func IsControlOverride
Self .IsStereotype st_ControlOverride
>>> Result
; // IsControlOverride
BOOLEAN elem_func IsControlPrim
Self .IsStereotype st_ControlPrim
>>> Result
; // IsControlPrim
BOOLEAN elem_func IsComponent
Self .IsStereotype st_Component
>>> Result
; // IsComponent
elem_iterator ImplementsEx
Self .Implements
>>> Result
; // ImplementsEx
/*{
f _CollectControlsPrim
<{}{%C#f_IsControl()=true}{}\
[{%C#f_IsOverride()!=true}\
[{%f_exists_in_list(CONTROLS,C)!=true}\
%f_add_to_list(CONTROLS,C)\
]\
]\
%f_CollectControlsPrim(%C)\
>
f _CollectControls
%f_CollectControlsPrim(%S)\
<%f_CollectControls(%G)>\
<%f_CollectControls(%R)>
}*/
elem_iterator CollectControls
Cached:
(
VAR l_Controls
[] >>> l_Controls
elem_proc CollectControlsPrim
Self .Attributes
.filter> .IsControlPrim
.filter> ( .IsControlOverride ! )
.filter> ( .NotInArray: l_Controls )
.for> (
IN aControl
aControl .AddToArray: l_Controls
aControl call.me
) // .for>
; // CollectControlsPrim
elem_proc DoCollectControls
Self .CollectControlsPrim
Self .InheritsEx .for> call.me
Self .ImplementsEx .for> call.me
; // DoCollectControls
Self .DoCollectControls
l_Controls
)
>>> Result
; // CollectControls
elem_iterator ScriptKeywordsPackProperties
Cached:
(
VAR l_Properties
Self .Attributes
.filter> ( .IsStereotype st_property::Attribute )
>>> l_Properties
l_Properties
Self .InheritsEx
.filter> .IsVCMForm
.filter> ( .Abstraction at_final == )
.for> (
IN aForm
aForm .CollectControls
.filter> ( .Visibility PublicAccess == )
.filter> ( .MainAncestor .NotIsNil )
.for> (
IN aControl
VAR l_Name
aControl .Name >>> l_Name
if ( l_Properties l_Name .HasModelElementWithName ! ) then
begin
.join> ToArray: (
l_Name
aControl .MainAncestor
MakeProperty: (
IN aMade
aMade -> UID := ( [ aForm .LUID '_' aControl .LUID '_Control' ] strings:Cat )
aMade -> Parent := ( Self .WeakRef )
aMade -> %SUM := ( [ 'Контрол ' l_Name ' формы ' aForm .TypeName ] strings:Cat )
aMade -> "NameForScript" := ( [ '.' aForm .TypeName '.' l_Name ] strings:Cat )
aMade -> Stereotype := st_readonly::Attribute
aMade -> "mapped" := true
aMade -> "ifdef" := ( aControl .GetUP "ifdef" )
aMade -> "ifndef" := ( aControl .GetUP "ifndef" )
) // MakeProperty:
) // .join> ToArray:
end // ( l_Properties l_Name .HasModelElementWithName ! )
) // .for>
) // .for>
)
>>> Result
; // ScriptKeywordsPackProperties
elem_iterator OperationsEx
Cached:
(
VAR l_Operations
Self .Operations >>> l_Operations
l_Operations
RULES
( Self .IsScriptKeyword )
begin
VAR l_Op
Self .KeywordOperation >>> l_Op
if (
( l_Op .IsNotNil )
AND ( l_Op .IsSomeKeyWord )
) then
begin
if (
( l_Op .GetUP 'extprop:prop_stereo' .IsValueValid )
OR ( l_Op .UPisTrue "lvalue" )
) then
begin
if (
( l_Op .UPisTrue "mapped" ! )
AND ( l_Op .GetUP 'extprop:prop_stereo' 'readonly' ?!= )
) then
begin
if ( l_Operations 'DoSetValue' .HasModelElementWithName ! ) then
begin
.join> ToArray: (
'DoSetValue' MakeProcedure: (
IN aMade
VAR l_Self
Self .KeywordObjectToOperate >>> l_Self
aMade -> UID := ( Self .LUID '_DoSetValue' Cat )
aMade -> %SUM := ( 'Метод установки значения свойства ' l_Op .Name Cat )
aMade -> Stereotype := st_static::Operation
aMade -> Visibility := ProtectedAccess
aMade -> Abstraction := at_final
aMade -> Parameters := (
ToArray: ( l_Self .OpSelfParam )
.join> ( l_Op .Parameters )
.join> ToArray: ( l_Op .Target .ValueParam )
) // aMade -> Parameters
) // MakeProcedure:
) // .join> ToArray:
end // ( l_Operations 'DoSetValue' .HasModelElementWithName ! )
end // ( l_Op .UPisTrue "mapped" ! )
end // ( l_Op .GetUP 'extprop:prop_stereo' .IsValueValid )
VAR l_Self
Self .KeywordObjectToOperate >>> l_Self
if (
( l_Op .UPisTrue "mapped" )
OR ( l_Self .NotIsNil )
OR ( l_Op .Parameters .NotEmpty )
OR ( l_Op .Target .NotIsNil )
OR ( l_Op .IsVarWorker )
) then
begin
VAR l_Name
l_Op .Name >>> l_Name
if ( l_Operations l_Name .HasModelElementWithName ! ) then
begin
.join> ToArray: (
l_Name
if ( l_Op .IsCreator ) then
begin
l_Self
end // ( l_Op .IsCreator )
else
begin
l_Op .Target
end // ( l_Op .IsCreator )
MakeFunction: (
IN aMade
aMade -> UID := ( l_Op .LUID )
// - пусть лучше мапируется на порождащую операцию, чтобы при переносе класса - не переделывать
aMade -> %SUM := ( 'Реализация слова скрипта ' Self .NameForScript Cat )
aMade -> Visibility := PrivateAccess
aMade -> Abstraction := at_final
aMade -> IsSummoned := true
// - это можно убрать, если перенести сюда вот что:
/*{
(
( Self .OpKind opkind_Normal == ) // - метод новый, а не перекрытый
AND ( l_Op .IsNotNil )
AND ( l_Self .IsNotNil )
AND ( l_Implementor .IsSummoned )
AND ( l_Op .UPisTrue "mapped" )
)
Code:
(
[
' '
if ( Self .Target .IsNotNil ) then
begin
'Result := '
end
'a' l_Self .SelfName cDot l_Op .Name l_Op .ParametersList ';'
] .Out
)
}*/
aMade -> SpelledFor := ( l_Op .WeakRef )
aMade -> Parameters := (
ToArray: ( GarantModel::TtfwContext .CtxParam )
if ( l_Op .IsVarWorker ) then
begin
.join> [
if ( l_Op .IsWordWorker ) then
'aWord'
else
'aVar'
GarantModel::TtfwWord MakeParam
] // .join>
end // ( l_Op .IsVarWorker )
if ( l_Op .IsCreator ! ) then
begin
if ( l_Self .NotIsNil ) then
begin
.join> ToArray: ( l_Self .OpSelfParam )
end // ( l_Self .NotIsNil )
end // ( l_Op .IsCreator ! )
.join> ( l_Op .Parameters )
) // aMade -> Parameters
VAR l_Ref
Self .WeakRef >>> l_Ref
l_Ref -> Stub := ( aMade .WeakRef )
// - обратная ссылка для l_Call
// %{Class_Inst}%f_set_var(Stub,{Op_Instance})\
) // MakeFunction:
) // .join> ToArray:
end // ( l_Operations l_Name .HasModelElementWithName ! )
end // ( l_Op .UPisTrue "mapped" )
end // ( l_Op .IsNotNil )
end // ( Self .IsScriptKeyword )
( Self .IsScriptKeywordsPack )
begin
Self .ScriptKeywordsPackProperties
.for> (
IN aProp
VAR l_Name
aProp .Name >>> l_Name
if ( l_Operations l_Name .HasModelElementWithName ! ) then
begin
.join> ToArray: (
l_Name
aProp .Target
MakeFunction: (
IN aMade
aMade -> UID := ( aProp .LUID )
aMade -> Parent := ( aProp .Parent .WeakRef )
aMade -> Stereotype := st_keyword::Operation
aMade -> %SUM := ( aProp .Documentation )
aMade -> "NameForScript" := ( aProp .GetUP "NameForScript" )
if ( aProp .IsStereotype st_readonly::Attribute ) then
begin
aMade -> 'extprop:prop_stereo' := 'readonly'
end // ( aProp .IsStereotype st_readonly::Attribute )
else
begin
aMade -> 'extprop:prop_stereo' := 'property'
end // ( aProp .IsStereotype st_readonly::Attribute )
aMade -> 'extprop:prop_name' := l_Name
aMade -> "mapped" := ( aProp .GetUP "mapped" )
aMade -> "is immediate" := ( aProp .GetUP "is immediate" )
aMade -> "ifdef" := ( aProp .GetUP "ifdef" )
aMade -> "ifndef" := ( aProp .GetUP "ifndef" )
) // MakeFunction:
) // .join> ToArray:
end // ( l_Operations l_Name .HasModelElementWithName ! )
) // .for>
end // ( Self .IsScriptKeywordsPack )
; // RULES
)
>>> Result
; // OperationsEx
ModelElement elem_func FirstOperation
Cached:
(
Self .OperationsEx
.filter> ( .IsLocalMethod ! )
.FirstElement
)
>>> Result
; // FirstOperation
BOOLEAN elem_func IsFacetIterator
Self .IsStereotype st_facetiterator
>>> Result
; // IsFacetIterator
BOOLEAN elem_func IsMixInMirror
Self .IsStereotype st_MixInMirror
>>> Result
; // IsMixInMirror
BOOLEAN elem_func IsVCMOperations
Self .IsStereotype st_VCMOperations
>>> Result
; // IsVCMOperations
BOOLEAN elem_func IsClassImplementable
Cached:
(
RULES
( Self .IsPureMixIn )
false
( Self .IsMixIn )
false
( Self .IsSimpleClass )
false
( Self .IsEvdSchemaElement )
false
( Self .IsMixInMirror )
false
( Self .IsStereotype st_UseCase )
false
( Self .IsVCMOperations )
false
( Self .IsInterface )
true
( Self .IsTypedef )
RULES
( Self .IsPointer )
false
DEFAULT
( Self .MainAncestor call.me )
; // RULES
DEFAULT
true
; // RULES
)
>>> Result
; // IsClassImplementable
BOOLEAN elem_func IsImplements
Self .IsStereotype st_implements::Dependency
>>> Result
; // IsImplements
ARRAY FUNCTION .mapToTarget>
ARRAY IN anArray
anArray .map> .Target
>>> Result
; // .mapToTarget>
WordAlias .KeepInStack NOP
ARRAY FUNCTION array:Copy
IN anArray
RULES
( anArray .IsNil )
[nil]
DEFAULT
(
VAR l_Empty
true >>> l_Empty
[
anArray .for> (
// .KeepInStack
// - это теперь не нужно, непустой функтор и так есть
false >>> l_Empty
) // anArray .for>
]
RULES
l_Empty
( DROP [nil] )
; // RULES
)
; // RULES
>>> Result
; // array:Copy
ARRAY FUNCTION array:CopyNotNil
IN anArray
[ anArray .for> .KeepInStack ]
>>> Result
; // array:CopyNotNil
elem_iterator ImplementsInDependencies
Cached:
(
Self .Dependencies
.filter> .IsImplements
.mapToTarget>
array:Copy
)
>>> Result
; // ImplementsInDependencies
elem_iterator ForClassImplements
Self .ImplementsEx
.filter> .IsClassImplementable
>>> Result
; // ForClassImplements
elem_iterator ClassImplementsPrim
Self .ForClassImplements
>>> Result
; // ClassImplementsPrim
BOOLEAN elem_func InTie
Cached:
(
RULES
( Self .IsNil )
false
( Self .GetUP "gui" 'tie' ?== )
true
( Self .Parent call.me )
true
DEFAULT
false
; // RULES
)
>>> Result
; // InTie
elem_iterator InterfaceForClassImplements
Self .ForClassImplements
.filter> ( .InTie ! )
>>> Result
; // InterfaceForClassImplements
ARRAY FUNCTION .joinWithLambded>
ARRAY IN anArrayToJoin
^ IN anArrayToIterate
^ IN aLambda
anArrayToJoin
anArrayToIterate DO .for> (
IN aChild
VAR l_Other
( aChild aLambda DO ) >>> l_Other
if ( l_Other .IsNotNil ) then
begin
.join> l_Other
end // ( l_Other .IsNotNil )
)
>>> Result
; // .joinWithLambded>
BOOLEAN elem_func IsMixInOrMixInMirror
RULES
( Self .IsMixIn )
true
( Self .IsMixInMirror )
true
DEFAULT
false
; // RULES
>>> Result
; // IsMixInOrMixInMirror
BOOLEAN elem_func SomeAncestorImplements
ModelElement IN anIntf
BOOLEAN elem_func ImplementsLoc
Self .ImplementsEx
.filter> ( anIntf .IsSameType )
.NotEmpty >>> Result
; // ImplementsLoc
anIntf :Cached:
(
RULES
( Self .IsTypedef )
RULES
( Self .IsPointer )
false
DEFAULT
( Self .MainAncestorPrim anIntf call.me )
; // RULES
( Self .InheritsEx .filter> ( anIntf .IsSameType ) .NotEmpty )
true
( Self .InheritsEx .filter> .ImplementsLoc .NotEmpty )
true
( Self .InheritsEx .filter> ( anIntf call.me ) .NotEmpty )
true
( Self .ImplementsEx .filter> .IsMixInOrMixInMirror .filter> .ImplementsLoc .NotEmpty )
true
( Self .ImplementsEx .filter> .IsMixInOrMixInMirror .filter> ( anIntf call.me ) .NotEmpty )
true
DEFAULT
false
; // RULES
)
>>> Result
; // SomeAncestorImplements
elem_iterator ClassImplements
(
Self .ClassImplementsPrim
.joinWithLambded> ( Self .ClassImplementsPrim ) .InterfaceForClassImplements
)
.filter> ( Self SWAP .SomeAncestorImplements ! )
array:Copy
>>> Result
; // ClassImplements
INTERFACE elem_func OverrideMethod
Cached:
(
Self .DecorateMethod:
(
IN aMethod
aMethod -> OpKind := opkind_Overridden
) // Self .DecorateMethod:
)
>>> Result
; // OverrideMethod
INTERFACE elem_func ImplementMethod
Cached:
(
Self .DecorateMethod:
(
IN aMethod
aMethod -> OpKind := opkind_Implemented
) // Self .DecorateMethod:
)
>>> Result
; // ImplementMethod
INTERFACE elem_func DecorateType
Cached:
(
Self .DecorateMethod:
(
IN aMethod
aMethod -> OpKind := opkind_DecoratedType
) // Self .DecorateMethod:
)
>>> Result
; // DecorateType
INTERFACE FUNCTION MakeInOutParam
STRING IN aName
ModelElement IN aType
aName aType MakeParam: (
IN aMade
aMade -> Stereotype := st_inout
)
>>> Result
; // MakeInOutParam
INTERFACE FUNCTION MakeClass:
STRING IN aName
ModelElement IN anAncestor
^ IN aLambda
KeyValuesCreateAndDo: ( IN l_Param
l_Param pop:Word:Box >>> Result
l_Param -> Name := aName
if ( anAncestor .IsNotNil ) then
begin
l_Param -> Inherits := [ anAncestor ]
end // ( anAncestor .IsNotNil )
l_Param aLambda DO
)
; // MakeClass:
INTERFACE FUNCTION MakeClass
STRING IN aName
ModelElement IN anAncestor
aName anAncestor MakeClass: DROP
>>> Result
; // MakeClass
CONST cImplementationUserCodeSuffix '_impl'
CONST cVarUserCodeSuffix '_var'
CONST cEmptyUserCode #1
CONST cUserCodePrefix 'uc:'
STRING FUNCTION cImplementationUserCodeName
cUserCodePrefix cImplementationUserCodeSuffix Cat >>> Result
; // cImplementationUserCodeName
STRING FUNCTION cVarUserCodeName
cUserCodePrefix cVarUserCodeSuffix Cat >>> Result
; // cVarUserCodeName
INTERFACE elem_func CastMethod
Cached:
(
VAR l_TypeName
Self .TypeName >>> l_TypeName
'As_' l_TypeName Cat Self MakeFunction: (
IN aMade
aMade -> %SUM := ( 'Метод приведения нашего интерфейса к ' l_TypeName Cat )
aMade -> Visibility := ProtectedAccess
aMade ->^ cVarUserCodeName ^:= cEmptyUserCode
aMade ->^ cImplementationUserCodeName ^:= ' Result := Self;'
)
)
>>> Result
; // CastMethod
BOOLEAN elem_func IsStaticOp
Self .IsStereotype st_static::Operation
>>> Result
; // IsStaticOp
BOOLEAN elem_func IsStaticMethod
RULES
( Self .IsStaticOp )
true
( Self .UPisTrue "is static" )
true
DEFAULT
false
; // RULES
>>> Result
; // IsStaticMethod
elem_iterator InterfaceOwnOperations
Self .OperationsEx
.filter> ( .IsStaticMethod ! )
.joinWithLambded> ( Self .InterfaceForClassImplements ) .ToArray: .CastMethod
>>> Result
; // InterfaceOwnOperations
elem_iterator InterfaceOperationsTotal
Cached:
(
Self .InterfaceOwnOperations
.joinWithLambded> ( Self .ImplementsEx .filter> .IsPureMixIn ) (
IN anItem
anItem call.me
.joinWithLambded> ( anItem .InheritsEx .filter> .IsPureMixIn ) .InterfaceOwnOperations
)
)
>>> Result
; // InterfaceOperationsTotal
ModelElement elem_func MainImplements
Cached:
(
Self .ImplementsEx
.FirstElement
)
>>> Result
; // MainImplements
BOOLEAN elem_func ImplementsIterator
Cached:
(
RULES
( Self .MainImplements .IsNil )
false
( Self .MainImplements .IsIterator )
true
DEFAULT
false
; // RULES
)
>>> Result
; // ImplementsIterator
BOOLEAN elem_func IsMethodAndImplementsIterator
RULES
( Self .IsMethod ! )
false
( Self .ImplementsIterator )
true
DEFAULT
false
; // RULES
>>> Result
; // IsMethodAndImplementsIterator
BOOLEAN elem_func SomeMethodImplementsThisIterator
ModelElement IN anIterator
RULES
(
Self .OperationsEx
.filter> .IsMethodAndImplementsIterator
.map> .MainImplements
.filter> ( anIterator .IsSameModelElement )
.NotEmpty
)
true
DEFAULT
false
; // RULES
>>> Result
; // SomeMethodImplementsThisIterator
elem_iterator InterfaceOperationsTotalDeep
Self .InterfaceOperationsTotal
.joinWithLambded> ( Self .InheritsEx .filter> .IsClassImplementable ) call.me
>>> Result
; // InterfaceOperationsTotalDeep
elem_iterator ImplementedEx
Cached:
(
Self .Implemented
if ( Self .IsClassOrMixIn ) then
begin
VAR l_OutedIterators
[] >>> l_OutedIterators
.joinWithLambded> ( Self .ClassImplements ) (
.InterfaceOperationsTotalDeep
.filter> ( .IsFacetIterator ! )
.filter> ( .IsIterator )
.filter> ( Self SWAP .SomeMethodImplementsThisIterator ! )
.filter> (
IN anItem
if ( anItem .NotInArray: l_OutedIterators ) then
begin
anItem .AddToArray: l_OutedIterators
true
end
else
false
) // .filter>
.filter> (
IN anItem
Self .MainAncestor call.me .filter> ( anItem .IsSameModelElement ) .IsEmpty
) // .filter>
.map> .ImplementMethod
array:Copy
)
end // ( Self .IsClassOrMixIn )
)
>>> Result
; // ImplementedEx
BOOLEAN elem_func IsFactoryAcceptable
RULES
( Self .IsInterface )
true
( Self .IsMixInParamType )
true
( Self .IsArray )
true
DEFAULT
false
; // RULES
>>> Result
; // IsFactoryAcceptable
ModelElement elem_func MainImplementsInterface
Cached:
(
Self .ImplementsEx
.filter> .IsFactoryAcceptable
.FirstElement
)
>>> Result
; // MainImplementsInterface
STRING elem_func UIDforUserCode
RULES
( Self .IsIterator )
RULES
(
( Self .MainAncestor .IsNotNil )
AND ( Self .MainAncestor .IsIterator )
)
( Self .MainAncestor .LUID )
DEFAULT
( Self .LUID )
; // RULES
( Self .IsMethodAndImplementsIterator )
( Self .MainImplements .LUID )
DEFAULT
( Self .LUID )
; // RULES
>>> Result
; // UIDforUserCode
BOOLEAN elem_func IsResultType
Self .IsStereotype st_result_type::Attribute
>>> Result
; // IsResultType
BOOLEAN elem_func IsElementType
Self .IsStereotype st_element_type::Attribute
>>> Result
; // IsElementType
BOOLEAN elem_func IsIndexType
Self .IsStereotype st_index_type::Attribute
>>> Result
; // IsIndexType
BOOLEAN elem_func IsServiceIterator
Self .IsStereotype st_serviceiterator >>> Result
; // IsServiceIterator
INTERFACE elem_func ItemParam
Cached:
(
'anItem' Self MakeParam
) >>> Result
; // ItemParam
INTERFACE elem_func IndexParam
Cached:
(
'anIndex' Self MakeParam
) >>> Result
; // IndexParam
BOOLEAN elem_func IsOverride
RULES
( Self .IsControlOverride )
true
( Self .IsIterator )
RULES
( Self .MainAncestor .IsNil )
false
DEFAULT
true
; // RULES
DEFAULT
false
; // RULES
>>> Result
; // IsOverride
ModelElement elem_func IteratorAction
Cached:
(
VAR l_Action
Self .Action >>> l_Action
RULES
( l_Action .IsNotNil )
l_Action
( Self .IsOverride )
( Self .MainAncestor call.me )
DEFAULT
begin
[ Self .Parent .Name cUnderline Self .Name '_Action' ] strings:Cat
nil
MakeFunction: (
IN aMade
aMade -> UID := ( Self .LUID '_Action' Cat )
aMade -> Parent := ( Self .Parent .WeakRef )
aMade -> Stereotype := st_Function
aMade -> %SUM := ( [
'Тип подитеративной функции для ' Self .Parent .Name '.' Self .Name
] strings:Cat
)
//aMade -> Parameters := [ GarantModel::Pointer .ActionParamPrim ]
aMade -> Visibility := PublicAccess
aMade -> Operations := [
'DoIt' GarantModel::Boolean MakeFunction: (
IN aMadeOp
aMadeOp -> Parameters := [
Self .Attributes
.filter> .IsElementType
.mapToTarget>
.FirstElement
.ItemParam
if ( Self .UPisTrue "needs index" ) then
begin
VAR l_IndexType
Self .Attributes
.filter> .IsIndexType
.mapToTarget>
.FirstElement >>> l_IndexType
if ( l_IndexType .IsNil ) then
begin
GarantModel::Integer >>> l_IndexType
end // ( l_IndexType .IsNil )
l_IndexType .IndexParam
end // ( Self .UPisTrue "needs index" )
] // aMadeOp -> Parameters
) // 'DoIt' GarantModel::Boolean MakeFunction:
] // aMade -> Operations
) // MakeFunction:
end // DEFAULT
; // RULES
) >>> Result
; // IteratorAction
INTERFACE elem_func ActionParamPrim
Cached:
(
'anAction' Self MakeParam
) >>> Result
; // ActionParamPrim
INTERFACE elem_func ActionParam
Cached:
(
Self .IteratorAction .ActionParamPrim
) >>> Result
; // ActionParam
ModelElement elem_func IteratorStub
Cached:
(
VAR l_Stub
Self .Stub >>> l_Stub
RULES
( l_Stub .IsNotNil )
l_Stub
( Self .IsServiceIterator )
begin
VAR l_MixIn
Self .Parent .MixIn >>> l_MixIn
l_MixIn .OperationsEx
.filter> .IsIterator
.filter> ( .IsServiceIterator ! )
.filter> ( .Name Self .Name 'F' Cat ?== )
.FirstElement
call.me
end // ( Self .IsServiceIterator )
( Self .IsOverride )
( Self .MainAncestor call.me )
DEFAULT
begin
[ 'L2_' Self .Parent .Name cUnderline Self .Name '_Action' ] strings:Cat Self .IteratorAction MakeFunction: (
IN aMade
aMade -> UID := ( Self .LUID '_Stub' Cat )
aMade -> Parent := ( Self .Parent .WeakRef )
aMade -> Stereotype := st_static::Operation
aMade -> %SUM := ( [
'Функция формирования заглушки для ЛОКАЛЬНОЙ подитеративной функции для ' Self .Parent .Name '.' Self .Name
] strings:Cat
)
aMade -> Parameters := [ GarantModel::Pointer .ActionParamPrim ]
aMade -> Visibility := PublicAccess
aMade -> 'extprop:isGlobal' := true
aMade -> 'extprop:isAsm' := true
) // MakeFunction:
end // DEFAULT
; // RULES
) >>> Result
; // IteratorStub
BOOLEAN elem_func IsInParam
Self .IsStereotype st_in::Attribute >>> Result
; // IsInParam
BOOLEAN elem_func IsContract
Self .IsStereotype st_Contract >>> Result
; // IsContract
ModelElement elem_func FriendClass
Cached:
(
VAR l_TypeName
Self .TypeName >>> l_TypeName
l_TypeName 'Friend' Cat Self MakeClass: (
IN aMade
aMade -> Stereotype := st_SimpleClass
aMade -> %SUM := ( 'Друг к классу ' l_TypeName Cat )
aMade -> Visibility := PrivateAccess
aMade -> Abstraction := at_abstract
aMade -> "ifdef" := ( Self .IfDefStr )
aMade -> "ifndef" := ( Self .IfNDefStr )
aMade -> "register in scripts" := false
)
)
>>> Result
; // FriendClass
ModelElement elem_func EffectiveType
Cached:
(
RULES
( Self .UPisTrue "is friend" )
( Self .MainAncestor .FriendClass )
DEFAULT
( Self .MainAncestor )
; // RULES
)
>>> Result
; // EffectiveType
ModelElement elem_func SelfParam
Cached:
(
'Self' Self MakeParam
)
>>> Result
; // SelfParam
CONST opModifyNone 1
CONST opModifySetter 2
CONST opModifyIteratorF 3
CONST opModifyTest 4
CONST opModifyExecute 5
CONST opModifyGetState 6
INTEGER elem_func OpModify
Self 'OpModify' opModifyNone .ElemMember >>> Result
; // OpModify
BOOLEAN elem_func IsIteratorF
Self .OpModify opModifyIteratorF ==
>>> Result
; // IsIteratorF
BOOLEAN elem_func IsWriteonlyProperty
Self .IsStereotype st_writeonly::Attribute
>>> Result
; // IsWriteonlyProperty
BOOLEAN elem_func IsSetter
RULES
( Self .IsWriteonlyProperty )
true
( Self .OpModify opModifySetter == )
true
DEFAULT
false
; // RULES
>>> Result
; // IsSetter
BOOLEAN elem_func IsTester
Self .OpModify opModifyTest == >>> Result
; // IsTester
BOOLEAN elem_func IsExecutor
Self .OpModify opModifyExecute == >>> Result
; // IsExecutor
BOOLEAN elem_func IsGetState
Self .OpModify opModifyGetState == >>> Result
; // IsGetState
BOOLEAN elem_func IsVCMOperationPrim
RULES
( Self .IsStereotype st_VCMOperationPrim )
true
(
( Self .Parent .IsNotNil )
AND ( Self .Parent .IsVCMOperations )
)
true
DEFAULT
false
; // RULES
>>> Result
; // IsVCMOperationPrim
BOOLEAN elem_func IsInternalOperation
Self .IsStereotype st_InternalOperation::Operation >>> Result
; // IsInternalOperation
INTERFACE elem_func ParamsParam
Cached:
(
'aParams' Self MakeParam
)
>>> Result
; // ParamsParam
INTERFACE elem_func StateParam
Cached:
(
'State' Self MakeInOutParam
)
>>> Result
; // StateParam
BOOLEAN elem_func IsFactoryMethod
Self .IsStereotype st_Factory
>>> Result
; // IsFactoryMethod
BOOLEAN elem_func IsFactory
RULES
( Self .IsStereotype st_factory::Operation )
true
( Self .IsFactoryMethod )
true
DEFAULT
false
; //RULES
>>> Result
; // IsFactory
ARRAY elem_func MethodParameters
Cached:
(
RULES
( Self .IsVCMOperationPrim )
RULES
( Self .IsTester )
( GarantModel::IvcmTestParamsPrim .ParamsParam .ToArray )
( Self .IsExecutor )
RULES
( Self .IsInternalOperation )
( Self .Parameters )
DEFAULT
( GarantModel::IvcmTestExecutePrim .ParamsParam .ToArray )
; // RULES
( Self .IsGetState )
( GarantModel::TvcmOperationStateIndex .StateParam .ToArray )
( Self .IsInternalOperation )
( GarantModel::IvcmTestExecutePrim .ParamsParam .ToArray )
DEFAULT
( Self .Parameters )
; // RULES
( Self .Parent .IsTestClass )
(
[ Self .Parent .EffectiveType .SelfParam ]
.join>
( Self .Parameters )
)
( Self .IsIterator )
(
RULES
( Self .MainAncestor .IsNotNil )
( Self .MainAncestor call.me )
DEFAULT
(
[ Self .ActionParam ]
.join> (
Self .Attributes
.filter> .IsInParam
) // .join>
) // DEFAULT
; // RULES
)
( Self .IsFactoryMethod )
RULES
( Self .MainAncestor .IsNotNil )
( Self .MainAncestor call.me )
DEFAULT
( Self .FirstOperation .Parameters )
; // RULES
( Self .IsMethod )
RULES
( Self .ImplementsIterator )
( Self .MainImplements call.me )
( Self .MainAncestor .IsNotNil )
RULES
( Self .FirstOperation .IsNotNil )
RULES
(
( Self .FirstOperation .IsSummoned )
AND ( Self .Abstraction at_regular == )
)
( Self .MainAncestor call.me )
DEFAULT
( Self .FirstOperation .Parameters )
; // RULES
DEFAULT
( Self .MainAncestor call.me )
; // RULES
DEFAULT
( Self .FirstOperation .Parameters )
; // ( Self .IsMethod )
( Self .IsFunction )
( Self .FirstOperation .Parameters )
DEFAULT
( Self .Parameters )
; // RULES
)
>>> Result
; // MethodParameters
elem_iterator PropertyKeys
RULES
( Self .Parent .IsTestClass )
(
[ Self .Parent .EffectiveType .SelfParam ]
.join>
( Self .Attributes )
)
DEFAULT
( Self .Attributes )
; // RULES
.filter> ( .IsControlPrim ! )
>>> Result
; // PropertyKeys
ARRAY FUNCTION .With()>
OUTABLE IN aValue
^ IN aLambda
RULES
( aValue .IsNil )
[empty]
( aValue IsArray )
(
[
VAR l_WasBracket
false >>> l_WasBracket
aValue
.filterNil>
.for> (
IN anItem
if ( l_WasBracket ! ) then
begin
'('
true >>> l_WasBracket
end
anItem aLambda DO
) // aValue .for>
if l_WasBracket then
begin
')'
end
]
) // ( aValue IsArray )
DEFAULT
[ '(' aValue aLambda DO ')' ]
; // RULES
>>> Result
; // .With()
ARRAY FUNCTION .With()
OUTABLE IN aValue
aValue .With()> .KeepInStack >>> Result
; // .With()
ARRAY FUNCTION .CommaListWith()
ARRAY IN aList
[
VAR l_WasComma
false >>> l_WasComma
aList .for> (
.WithComma: l_WasComma .KeepInStack
)
] .With() >>> Result
; // .CommaListWith()
ARRAY elem_func ParametersList
Cached:
(
Self .MethodParameters .map> .Name .CommaListWith()
)
>>> Result
; // ParametersList
CONST cUCStart '//#UC START# *'
CONST cUCEnd '//#UC END# *'
PROCEDURE ReadUCFromFile
STRING IN aFileName
STRING IN aCurrentGeneratedElementPrefix
if ( aFileName sysutils:FileExists ) then
begin
FILE VAR l_In
aFileName TryOpen: File:OpenRead >>> l_In
TRY
VAR l_UCOpened
ARRAY VAR l_Accumulated
STRING VAR l_Key
false >>> l_UCOpened
l_In File:ReadLines (
IN aStr
VAR l_Pos
: Has
string:Pos >>> l_Pos
l_Pos -1 !=
; // Has
RULES
( aStr cUCStart Has )
(
l_UCOpened ! ?ASSURE [ 'Секция кода уже открыта. Файл: ' aFileName ' строка:' aStr ]
true >>> l_UCOpened
aStr string:Trim >>> aStr
[] >>> l_Accumulated
aStr >>> l_Key
'*' string:SplitTo! l_Key DROP
)
( aStr cUCEnd Has )
(
l_UCOpened ?ASSURE [ 'Секция кода не открыта. Файл: ' aFileName ' строка:' aStr ]
false >>> l_UCOpened
VAR l_Head
if ( l_Pos > 0 ) then
begin
l_Pos 0 aStr string:Substring >>> l_Head
if ( l_Head string:TrimLeft .IsNotNil ) then
begin
l_Head .AddToArray: l_Accumulated
aStr string:Len l_Pos -
l_Pos
aStr
string:Substring >>> aStr
end // ( l_Head .IsNotNil )
end // ( l_Pos > 0 )
aStr string:Trim >>> aStr
g_CurrentGenerator ->^ l_Key ^:= l_Accumulated
g_CurrentGenerator ->^ ( aCurrentGeneratedElementPrefix l_Key Cat ) ^:= l_Accumulated
nil >>> l_Accumulated
)
DEFAULT
(
l_UCOpened ? (
aStr .AddToArray: l_Accumulated
) // l_UCOpened ?
)
; // RULES
) // l_In File:ReadLines
FINALLY
nil >>> l_In
END // TRY..FINALLY
end // ( aFileName sysutils:FileExists )
; // ReadUCFromFile
CONST cPalka '|'
elem_proc OutUserCode:
STRING IN aKey
^ IN aOutExisting
^ IN aOutNew
BOOLEAN VAR l_Found
false >>> l_Found
if ( g_UCRead ! ) then
begin
true >>> g_UCRead
STRING VAR l_TempFileName
g_TempFileName '.uc.txt' Cat >>> l_TempFileName
STRING VAR l_RealFileName
g_RealFileName '.uc.txt' Cat >>> l_RealFileName
STRING VAR l_CurrentGeneratedElementPrefix
[ cUserCodePrefix g_CurrentGeneratedElement .LUID cPalka ] strings:Cat >>> l_CurrentGeneratedElementPrefix
l_RealFileName l_CurrentGeneratedElementPrefix ReadUCFromFile
g_FinalFileNameForUC l_CurrentGeneratedElementPrefix ReadUCFromFile
FILE VAR l_Out
l_TempFileName MakePathAndOpenWrite >>> l_Out
TRY
g_CurrentGenerator MembersIterator
.filter> ( .WordName l_CurrentGeneratedElementPrefix SWAP StartsStr )
.for> (
IN anItem
STRING VAR l_Key
anItem .WordName cPalka string:Split >>> l_Key DROP
cUCStart l_Out File:WriteStr
l_Key l_Out File:WriteWStrLn
anItem DO .for> ( l_Out File:WriteWStrLn )
cUCEnd l_Out File:WriteStr
l_Key l_Out File:WriteWStrLn
) // g_CurrentGenerator MembersIterator
FINALLY
nil >>> l_Out
END // TRY..FINALLY
l_RealFileName l_TempFileName false CopyChangedFile
if ( l_RealFileName FileSize 0 == ) then
begin
l_RealFileName false DoDeleteFile
end // ( l_RealFileName FileSize 0 == )
end //( g_UCRead ! )
l_Found ! ? (
VAR l_Field
g_CurrentGenerator %% aKey >>> l_Field
if ( l_Field .IsNil ) then
begin
aKey aOutNew DO
end // ( l_Field .IsNil )
else
begin
aKey l_Field DO aOutExisting DO
end // ( l_Field .IsNil )
) // l_Found ! ?
; // OutUserCode:
elem_proc DefaultUserCodePrim:
STRING IN aSuffix
STRING IN aKey
^ IN aOutNew
VAR l_KeyStart
Self .UIDforUserCode >>> l_KeyStart
l_KeyStart aKey Cat >>> aKey
aKey '*' Cat >>> aKey
Self aKey .OutUserCode: (
IN aKey
IN aValue
[ cUCStart aKey ] .Out
aValue .for> ( g_OutFile File:WriteWStrLn )
[ cUCEnd aKey ] .Out
) (
IN aKey
VAR l_Field
nil >>> l_Field
if ( aSuffix .NotIsNil ) then
begin
// - вообще говоря тут затычка для переноса слов скрипта в новый генератор
if ( [ l_KeyStart cUnderline l_KeyStart ] strings:Cat aKey StartsStr ) then
// - проверяем, что это слово скрипта у которого родитель поменял UID
// - тут ещё надо KeywordObjectToOperate проверять
begin
g_CurrentGenerator MembersIterator
.filter> ( .WordName l_KeyStart SWAP StartsStr )
.filter> ( .WordName aSuffix '*' Cat SWAP EndsStr )
.FirstElement >>> l_Field
end
end // ( aSuffix .NotIsNil )
if ( l_Field .IsNil ) then
begin
aKey aOutNew DO
end // ( l_Field .IsNil )
else
begin
[ cUCStart aKey ] .Out
l_Field DO .for> ( g_OutFile File:WriteWStrLn )
[ cUCEnd aKey ] .Out
//l_Field .WordName Msg
end // ( l_Field .IsNil )
) // Self aKey .OutUserCode:
; // DefaultUserCodePrim:
elem_proc DefaultUserCode
STRING IN aSuffix
STRING IN aKey
TtfwWord IN aCode
Self aSuffix aKey .DefaultUserCodePrim: (
IN aKey
[ cUCStart aKey ] .Out
[ aCode DO ] .Out
[ cUCEnd aKey ] .Out
) // Self aKey .OutUserCode:
; // DefaultUserCode
elem_proc PredefinedUserCode:
STRING IN aSuffix
STRING IN aKey
^ IN aOutLambda
^ IN aCode
Self aSuffix aKey .DefaultUserCodePrim: (
IN aKey
[ aCode DO ] aOutLambda DO
) // Self aKey .OutUserCode:
; // PredefinedUserCode:
elem_proc PredefinedMethodUserCode:
STRING IN aSuffix
STRING IN aKey
TtfwWord IN aCode
^ IN aVarCode
^ IN aImplCode
RULES
( aSuffix cVarUserCodeSuffix == )
( Self aSuffix aKey .PredefinedUserCode: .Out ( aVarCode DO ) )
( aSuffix cImplementationUserCodeSuffix == )
( Self aSuffix aKey .PredefinedUserCode: ( IN aValue Indented: ( aValue .Out ) ) ( aImplCode DO ) )
DEFAULT
( Self aSuffix aKey aCode .DefaultUserCode )
; // RULES
; // PredefinedMethodUserCode:
elem_proc PredefinedMethodUserCodeWithoutVar:
STRING IN aSuffix
STRING IN aKey
TtfwWord IN aCode
^ IN aImplCode
Self aSuffix aKey aCode .PredefinedMethodUserCode: () ( aImplCode DO )
; // PredefinedMethodUserCodeWithoutVar:
ModelElement elem_func ImplementorOrParent
//Cached:
(
g_Implementor >>> Result
if ( Result .IsNil ) then
begin
Self .Parent >>> Result
end // ( Result .IsNil )
Result
)
>>> Result
; // ImplementorOrParent
BOOLEAN elem_func IsReadonlyProperty
Self .IsStereotype st_readonly::Attribute >>> Result
; // IsReadonlyProperty
BOOLEAN elem_func IsProperty
Cached:
(
RULES
( Self .IsStereotype st_property::Attribute )
true
( Self .IsReadonlyProperty )
true
( Self .IsWriteonlyProperty )
true
DEFAULT
false
; // RULES
)
>>> Result
; // IsProperty
INTERFACE elem_func InterfaceLinkField
Cached:
(
VAR l_TypeName
Self .TypeName >>> l_TypeName
'f_' l_TypeName Cat Self MakeField: (
IN aMade
aMade -> %SUM := ( 'Ссылка на интерфейс ' l_TypeName Cat )
aMade -> Visibility := PrivateAccess
)
)
>>> Result
; // InterfaceLinkField
BOOLEAN elem_func IsAutoHelper
Self .UPisTrue "IsAutoHelper" >>> Result
; // IsAutoHelper
STRING elem_func FieldName
RULES
( Self .IsProperty )
( 'f_' Self .Name Cat )
DEFAULT
( Self .Name )
; // RULES
>>> Result
; // FieldName
BOOLEAN elem_func HasFieldName
STRING IN aName
Self .FieldName aName ==
>>> Result
; // HasFieldName
elem_iterator Properties
Cached:
(
VAR l_Properties
Self .Attributes
.filter> .IsProperty
.filter> ( .IsControlOverride ! )
>>> l_Properties
l_Properties
if ( Self .IsService ) then
begin
VAR l_Facet
Self .Facet >>> l_Facet
if ( l_Facet .IsNotNil ) then
begin
if ( l_Properties 'Alien' .HasModelElementWithName ! ) then
begin
VAR l_TypeName
l_Facet .TypeName >>> l_TypeName
.join>
[
'Alien' l_Facet MakeProperty: (
IN aMade
aMade -> %SUM := ( 'Внешняя реализация сервиса ' l_TypeName Cat )
aMade -> Visibility := PublicAccess
aMade -> Stereotype := st_writeonly::Attribute
aMade -> Abstraction := at_final
aMade -> LinkType := lt_ref
aMade -> "pm" := true
aMade -> "needs field" := true
) // 'Alien' l_Facet MakeProperty:
] // .join>
end // ( l_Properties 'Alien' .HasModelElementWithName ! )
end // ( l_Facet .IsNotNil )
end // ( Self .IsService )
)
>>> Result
; // Properties
BOOLEAN elem_func NeedPutToDFM
Cached:
(
Self .UPisTrue "put to dfm" >>> Result
if Result then
begin
if ( Self .Parent .IsControlPrim ) then
begin
Self .Parent call.me >>> Result
end // ( Self .Parent .IsControlPrim )
end // Result
Result
)
>>> Result
; // NeedPutToDFM
BOOLEAN elem_func ReadsField
RULES
( Self .IsControlPrim )
( Self .NeedPutToDFM ! )
( Self .IsWriteonlyProperty )
true
( Self .UPisTrue "reads field" )
true
DEFAULT
false
; // RULES
>>> Result
; // elem_func ReadsField
BOOLEAN elem_func WritesField
RULES
( Self .IsReadonlyProperty )
true
( Self .UPisTrue "writes field" )
true
DEFAULT
false
; // RULES
>>> Result
; // elem_func WritesField
BOOLEAN elem_func NeedsField
RULES
( Self .IsOverride )
false
( Self .IsControlPrim )
RULES
( Self .NeedPutToDFM )
false
DEFAULT
true
; // RULES
( Self .UPisTrue "reads field" )
true
( Self .UPisTrue "writes field" )
true
( Self .Parent .IsInterface )
RULES
( Self .UPisTrue "needs field" )
true
DEFAULT
false
; // RULES
( Self .Abstraction at_abstract == )
false
( Self .UPisTrue "needs field" )
true
DEFAULT
false
; // RULES
>>> Result
; // NeedsField
BOOLEAN elem_func CanMapPropertiesToFields
RULES
( Self .IsClassOrMixIn )
true
( Self .IsException )
true
DEFAULT
false
; // RULES
>>> Result
; // CanMapPropertiesToFields
elem_iterator Fields
Cached:
(
VAR l_Fields
Self .Attributes
.filter> ( .IsProperty ! )
.filter> ( .IsStereotype st_impurity_value::Attribute ! )
.filter> ( .IsStereotype st_switch::Attribute ! )
.filter> ( .IsStereotype st_impurity_param::Attribute ! )
.filter> ( .IsStereotype st_static::Attribute ! )
>>> l_Fields
if ( Self .CanMapPropertiesToFields ) then
begin
l_Fields array:Copy >>> l_Fields
l_Fields
.joinWithLambded> (
Self .Properties
.join> (
Self .Implemented
.filter> .IsProperty
.filter> ( .Parent .IsInterface )
) // .join>
.filter> .NeedsField
.filter> (
IN anItem
l_Fields .HasSomeOf: ( anItem .FieldName .HasName ) !
// l_Fields .HasSomeOf: ( anItem .FieldName .HasFieldName ) !
) // .filter>
) .ToArray
end // ( Self .CanMapPropertiesToFields )
else
l_Fields
if ( Self .IsStaticObject ) then
begin
if ( Self .IsAutoHelper ) then
begin
.joinWithLambded> ( Self .ImplementsEx ) .ToArray: .InterfaceLinkField
end // ( Self .IsAutoHelper )
end // ( Self .IsStaticObject )
)
>>> Result
; // Fields
BOOLEAN elem_func IsSingleton
Self .UPisTrue "singleton" >>> Result
; // IsSingleton
BOOLEAN elem_func HasFactory
Cached:
(
Self .OperationsEx
.filter> .IsFactory
.NotEmpty
)
>>> Result
; // HasFactory
INTERFACE elem_func InstanceField
Cached:
(
VAR l_TypeName
Self .TypeName >>> l_TypeName
'g_' l_TypeName Cat
if ( Self .HasFactory ) then
GarantModel::Pointer
else
Self
MakeField: (
IN aMade
aMade -> %SUM := ( 'Экземпляр синглетона ' l_TypeName Cat )
aMade -> Visibility := PrivateAccess
aMade -> 'extprop:pas:Value' := 'nil'
aMade -> "ifdef" := ( Self .IfDefStr )
aMade -> "ifndef" := ( Self .IfNDefStr )
)
)
>>> Result
; // InstanceField
BOOLEAN elem_func IsLocalVar
Self .IsStereotype st_var::Attribute >>> Result
; // IsLocalVar
BOOLEAN elem_func IsGlobalVar
Self .IsStereotype st_globalvar::Attribute >>> Result
; // IsGlobalVar
elem_iterator InnerGlobalVars
Self .Attributes
.filter> .IsGlobalVar
.joinWithLambded> ( Self .OperationsEx ) call.me
>>> Result
; // InnerGlobalVars
elem_iterator GlobalVars
RULES
( Self .IsClassOrMixIn )
(
Self .Attributes
.filter> ( .IsStereotype st_static::Attribute )
if ( Self .IsSingleton ) then
begin
.join> ToArray: ( Self .InstanceField )
end // ( Self .IsSingleton )
.join> ( Self .InnerGlobalVars )
)
( Self .IsUtilityPack )
(
Self .Attributes
.filter> ( .IsProperty ! )
.join> ( Self .InnerGlobalVars )
)
DEFAULT
[empty]
; // RULES
>>> Result
; // GlobalVars
BOOLEAN elem_func IsWideString
Cached:
(
RULES
( Self .Name 'a-string' == )
false
( Self .Name 'a-wstring' == )
true
( Self .IsTypedef )
RULES
( Self .IsPointer )
false
DEFAULT
( Self .MainAncestor call.me )
; // RULES
DEFAULT
false
; // RULES
)
>>> Result
; // IsWideString
BOOLEAN elem_func IsString
Cached:
(
RULES
( Self .Name 'a-string' == )
true
( Self .IsWideString )
true
( Self .IsTypedef )
RULES
( Self .IsPointer )
false
DEFAULT
( Self .MainAncestor call.me )
; // RULES
DEFAULT
false
; // RULES
)
>>> Result
; // IsString
BOOLEAN elem_func IsUntyped
Self .Name 'void' == >>> Result
; // IsUntyped
BOOLEAN elem_func IsManaged
Cached:
(
RULES
( Self .IsRecord )
true
( Self .IsUnion )
true
( Self .IsArray )
true
( Self .IsInterface )
true
( Self .IsTypedef )
RULES
( Self .IsPointer )
false
DEFAULT
( Self .MainAncestor call.me )
; // RULES
( Self .IsMixInParamType )
true
( Self .IsString )
true
( Self .IsUntyped )
true
DEFAULT
false
; // RULES
)
>>> Result
; // IsManaged
BOOLEAN elem_func IsConstants
Self .IsStereotype st_Constants >>> Result
; // IsConstants
BOOLEAN elem_func IsSetConst
Self .IsStereotype st_SetConst >>> Result
; // IsSetConst
BOOLEAN elem_func IsConstantArray
Self .IsStereotype st_ConstantArray >>> Result
; // IsConstantArray
BOOLEAN elem_func IsLocalConst
Self .IsStereotype st_LocalConst >>> Result
; // IsLocalConst
BOOLEAN elem_func IsChoices
Self .IsStereotype st_Choices
>>> Result
; // IsChoices
BOOLEAN elem_func IsChoice
Self .IsStereotype st_Choice
>>> Result
; // IsChoice
BOOLEAN elem_func IsConstantsButNotType
RULES
( Self .IsRange )
false
( Self .IsConstants )
true
( Self .IsSetConst )
true
( Self .IsConstantArray )
true
( Self .IsLocalConst )
true
( Self .IsMessage )
true
( Self .IsChoices )
true
( Self .IsChoice )
true
DEFAULT
false
; // RULES
>>> Result
; // IsConstantsButNotType
BOOLEAN elem_func IsType
Cached:
(
RULES
( Self .MDAClass class_Operation == )
false
( Self .MDAClass class_Attribute == )
false
( Self .MDAClass class_Parameter == )
false
( Self .MDAClass class_Category == )
false
( Self .MDAClass class_Dependency == )
false
DEFAULT
RULES
( Self .IsConstantsButNotType )
false
( Self .IsVCMOperations )
false
( Self .IsControlPrim )
false
( Self .IsProperty )
false
( Self .IsMethod )
false
( Self .IsElementProxy )
false
( Self .IsTestClass )
false
( Self .IsUserType )
false
( Self .IsUtilityPack )
false
( Self .IsInterfaces )
false
( Self .IsTarget )
false
( Self .IsEvdSchemaElement )
false
( Self .IsPureMixIn )
false
( Self .IsDefine )
false
( Self .IsMixIn )
false
( Self .IsMixInParamType )
false
DEFAULT
true
; // RULES
; // RULES
)
>>> Result
; // IsType
STRING CompileTime-VAR g_IfDefStr ''
STRING CompileTime-VAR g_IfNDefStr ''
ARRAY CompileTime-VAR g_IfDefArr []
ARRAY CompileTime-VAR g_IfNDefArr []
BOOLEAN CompileTime-VAR g_WasType false
ModelElement CompileTime-VAR g_WasTypeOpener nil
BOOLEAN CompileTime-VAR g_WasConst false
BOOLEAN CompileTime-VAR g_WasForwarded false
PROCEDURE DropWasType
false >>> g_WasType
nil >>> g_WasTypeOpener
; // DropWasType
elem: IfDefPrim:
IN aElseLambda
^ IN aOutLambda
^ IN aLambda
if ( Self IsString ! ) then
begin
TF g_IfDefStr (
TF g_IfNDefStr (
TF g_IfDefArr (
TF g_IfNDefArr (
VAR l_IfDefStr
Self .IfDefStr >>> l_IfDefStr
VAR l_IfNDefStr
Self .IfNDefStr >>> l_IfNDefStr
BOOLEAN VAR l_NeedOut
false >>> l_NeedOut
ARRAY VAR l_Body
nil >>> l_Body
: OutIfBody
STRING IN anOpen
STRING IN aClose
VAR l_NeedAND
false >>> l_NeedAND
: OutItem
IN anItem
STRING IN aPrefix
ARRAY IN anOuted
if ( anItem .IsNotNil ) then
begin
if ( anItem .TextNotInArray: anOuted ) then
begin
anItem .AddToArray: anOuted
true >>> l_NeedOut
cSpace
if l_NeedAND then
begin
'AND' cSpace
end
else
begin
true >>> l_NeedAND
end // l_NeedAND
aPrefix 'Defined(' anItem ')'
end // ( anItem .TextNotInArray: anOuted )
end // ( anItem .IsNotNil )
; // OutItem
[
l_IfDefStr ',' string:Split:for> ( cEmptyStr g_IfDefArr OutItem )
l_IfNDefStr ',' string:Split:for> ( 'NOT ' g_IfNDefArr OutItem )
] >>> l_Body
if l_NeedOut then
begin
[
anOpen
l_Body
aClose
if ( g_EnableAutoEOL ! ) then
\n
] aOutLambda DO
end // l_NeedOut
; // OutIfBody
if ( ( l_IfDefStr .IsNotNil ) OR ( l_IfNDefStr .IsNotNil ) ) then
begin
if ( ( l_IfDefStr g_IfDefStr != ) OR ( l_IfNDefStr g_IfNDefStr != ) ) then
begin
g_IfDefArr array:CopyNotNil >>> g_IfDefArr
g_IfNDefArr array:CopyNotNil >>> g_IfNDefArr
l_IfDefStr >>> g_IfDefStr
l_IfNDefStr >>> g_IfNDefStr
: IfOut
cOpenComment '$If' Cat cCloseComment OutIfBody
; // IfOut
if g_NeedOutLn then
begin
false >>> g_NeedOutLn
OutLnToFile
end // g_NeedOutLn
IfOut
end // ( ( l_IfDefStr g_IfDefStr != ) OR ( l_IfNDefStr g_IfNDefStr != ) )
end // ( ( l_IfDefStr .IsNotNil ) OR ( l_IfNDefStr .IsNotNil ) )
aLambda DO
if l_NeedOut then
begin
: IfEndOut
false >>> l_NeedOut
nil >>> g_IfDefArr
nil >>> g_IfNDefArr
if ( aElseLambda .IsNotNil ) then
begin
[ cOpenComment '$Else' l_Body cCloseComment \n ] aOutLambda DO
aElseLambda DO
end // ( aElseLambda .IsNotNil )
[
cOpenComment '$IfEnd' cCloseComment cSpace '//'
l_Body
if g_NeedOutLn then
begin
false >>> g_NeedOutLn
\n
end // g_NeedOutLn
] aOutLambda DO
nil >>> l_Body
if ( Self .IsType ) then
begin
if ( g_WasForwarded ! ) then
begin
if ( g_WasTypeOpener Self ?== ) then
begin
DropWasType
end // ( g_WasTypeOpener Self ?== )
end // ( g_WasForwarded ! )
end // ( Self .IsType )
; // IfEndOut
IfEndOut
end // l_NeedOut
) // TF g_IfNDefArr
) // TF g_IfDefArr
) // // TF g_IfNDefStr
) // TF g_IfDefStr
end // ( Self IsString ! )
else
begin
aLambda DO
end // ( Self IsString ! )
; // IfDefPrim:
elem_proc IfDef:
^ IN aLambda
Self nil .IfDefPrim: .Out ( aLambda DO )
; // IfDef:
elem_proc IfDefElse:
^ IN aLambda
^ IN aElseLambda
Self aElseLambda .IfDefPrim: .Out ( aLambda DO )
; // IfDefElse:
BOOLEAN elem_func IsConstructor
RULES
( Self .IsStereotype st_ctor::Operation )
true
( Self .IsStereotype st_Constructor )
true
DEFAULT
false
; //RULES
>>> Result
; // IsConstructor
BOOLEAN elem_func IsStaticConstructor
RULES
( Self .IsConstructor )
RULES
( Self .Parent .IsRecord )
true
DEFAULT
false
; // RULES
DEFAULT
false
; //RULES
>>> Result
; // IsStaticConstructor
BOOLEAN elem_func NeedsFinalize
Cached:
(
RULES
( Self .IsNil )
false
DEFAULT
RULES
(
Self .Attributes
.mapToTarget>
.filter> .IsManaged
.NotEmpty
)
true
( Self .MainAncestor call.me )
true
DEFAULT
false
; // RULES
; // RULES
)
>>> Result
; // NeedsFinalize
BOOLEAN elem_func ParentIsInterface
Cached:
(
Self .Parent .IsInterface
)
>>> Result
; // ParentIsInterface
INTEGER elem_func FieldLinkType
RULES
( Self .IsProperty )
RULES
( Self .ParentIsInterface )
lt_ref
( Self .LinkType lt_lnk == )
lt_lnk
DEFAULT
lt_ref
; // RULES
DEFAULT
( Self .LinkType )
; // RULES
>>> Result
; // FieldLinkType
BOOLEAN elem_func IsFieldForCleanup
( Self .FieldLinkType lt_ref == )
AND ( Self .Target .IsManaged )
AND (
( Self .GetUP 'extprop:clearViaProperty' .IsNil )
OR ( Self .Target .IsMixInParamType ! )
)
>>> Result
; // IsFieldForCleanup
BOOLEAN elem_func IsVCMApplication
Self .IsStereotype st_VCMApplication
>>> Result
; // IsVCMApplication
elem_proc MethodUserCode
STRING IN aKey
TtfwWord IN aCode
STRING VAR l_Key
aKey >>> l_Key
VAR l_Implementor
Self .ImplementorOrParent >>> l_Implementor
RULES
( l_Key 'iter' == )
()
( l_Key 'afteriter' == )
()
( l_Key 'iterparam' == )
()
DEFAULT
(
RULES
( Self .IsSetter ) then
( 'set' l_Key Cat >>> l_Key )
( Self .IsProperty ) then
( 'get' l_Key Cat >>> l_Key )
( Self .IsTester ) then
( 'test' l_Key Cat >>> l_Key )
( Self .IsExecutor ) then
( 'exec' l_Key Cat >>> l_Key )
( Self .IsGetState ) then
( 'getstate' l_Key Cat >>> l_Key )
; // RULES
if ( l_Implementor .IsNotNil ) then
begin
[
cUnderline
if ( Self .IsLocalMethod ! ) then
begin
l_Implementor .LUID
end // ( Self .IsLocalMethod ! )
l_Key
] strings:Cat >>> l_Key
end // ( l_Implementor .IsNotNil )
) // DEFAULT
; // RULES
BOOLEAN elem_func IsSingletonExists
Self .Name 'Exists' ==
AND ( Self .IsStaticOp )
AND ( l_Implementor .IsSingleton )
>>> Result
; // IsSingletonExists
: WithoutVar:
^ IN aImplCode
Self aKey l_Key aCode .PredefinedMethodUserCodeWithoutVar: ( aImplCode DO )
; // WithoutVar:
RULES
( Self .IsSingletonExists )
(
WithoutVar:
(
'Result := g_' l_Implementor .TypeName ' <> nil;'
)
) // ( Self .IsSingletonExists )
(
Self .Name 'Alien' ==
AND ( Self .IsSetter )
AND ( l_Implementor .IsService )
)
(
WithoutVar:
(
'Assert((f_Alien = nil) OR (aValue = nil));' \n
'f_Alien := aValue;'
)
) // Self .Name 'Alien' ==
(
( Self .LUID GarantModel::TComponent.Loaded .LUID == ) // TComponent.Loaded
AND ( l_Implementor .IsVCMApplication )
)
(
WithoutVar:
(
'inherited;'
)
)
( Self .LUID '4C937013031D' == ) // GetFolder
(
WithoutVar:
(
'Result := ' cQuote l_Implementor .Parent .Name cQuote ';'
)
)
( Self .LUID '4DAED6F60146' == ) // GetModelElementGUID
(
WithoutVar:
(
'Result := ' cQuote l_Implementor .LUID cQuote ';'
)
)
(
Self .LUID '4EE1DC8903BB' == // GetInteger
AND ( l_Implementor .Parent .IsUserType )
)
WithoutVar: ( 'Result := ' l_Implementor .Parent .Name ';' )
( Self .LUID GarantModel::TtfwAxiomaticsResNameGetter.ResName .LUID == ) // ResName
WithoutVar: ( 'Result := ' cQuote l_Implementor .EffectiveUnitName cQuote ';' )
( Self .LUID '4DB079E00084' == ) // GetModuleOperationCode
(
WithoutVar:
(
'Result := TdmStdRes.mod_opcode_'
l_Implementor .Name
'Tkw_' .CutPrefix
'_op' cUnderline string:ReplaceFirst
';'
)
)
( Self .LUID GarantModel::TtfwRegisterableWord.GetWordNameForRegister .LUID == ) // GetWordNameForRegister
(
WithoutVar:
(
'Result := '
cQuote
VAR l_NameForScript
l_Implementor .NameForScript >>> l_NameForScript
if ( l_NameForScript .IsValueValid ) then
begin
ANY FUNCTION Mangle
IN aValue
RULES
( aValue IsBool )
RULES
aValue
'true'
DEFAULT
'false'
; // RULES
DEFAULT
aValue
; // RULES
>>> Result
; // Mangle
l_NameForScript Mangle
end // ( l_NameForScript .IsValueValid )
else
begin
l_Implementor .Parent .GetUP 'extprop:pas:ElementPrefixBase'
l_Implementor .Name cUnderline ':' string:Replace
end // ( l_NameForScript .IsValueValid )
cQuote
';'
) // ( Self .Name 'GetWordNameForRegister' == )
)
( Self .LUID GarantModel::l3UnknownPrim.ClearFields .LUID == ) // ClearFields
(
WithoutVar:
(
l_Implementor .Fields
.filter> .IsFieldForCleanup
.for> (
IN aField
aField nil .IfDefPrim: \n
(
VAR l_FieldName
aField .GetUP 'extprop:clearViaProperty' >>> l_FieldName
if (
( aField .Target .CannotFinalizeProperty )
OR ( l_FieldName .IsNil )
) then
begin
RULES
(
( aField .IsReadonlyProperty )
OR ( aField .Target .CannotFinalizeProperty )
)
( aField .FieldName >>> l_FieldName )
(
( aField .IsProperty )
AND ( aField .LinkType lt_agr == )
AND ( aField .Target .IsWideString )
)
// http://mdp.garant.ru/pages/viewpage.action?pageId=594895802&focusedCommentId=620849995#comment-620849995
( aField .FieldName >>> l_FieldName )
DEFAULT
( aField .Name >>> l_FieldName )
; // RULES
end // ( l_FieldName .IsNil )
RULES
( aField .Target .IsInterface )
( l_FieldName ' := nil' )
( aField .Target .IsString )
( l_FieldName ' := ' cQuote cQuote )
( aField .Target .IsOpenArray )
( l_FieldName ' := nil' )
DEFAULT
( 'Finalize(' l_FieldName ')' )
; // RULES
';' \n
) // aField .IfDef:
) // l_Implementor .Fields
'inherited;'
)
)
DEFAULT
(
if ( Self .IsStaticConstructor ) then
begin
if ( aKey cImplementationUserCodeSuffix == ) then
begin
if ( l_Implementor .NeedsFinalize ) then
begin
' Finalize(Result);' .Out
end // ( l_Implementor .NeedsFinalize )
' System.FillChar(Result, SizeOf(Result), 0);' .Out
end // ( aKey cImplementationUserCodeSuffix == )
end // ( Self .IsStaticConstructor )
Self aKey l_Key aCode .DefaultUserCode
)
; // RULES
; // MethodUserCode
BOOLEAN elem_func IsIni
Self .IsStereotype st_ini::Operation >>> Result
; // IsIni
BOOLEAN elem_func IsFini
Self .IsStereotype st_fini::Operation >>> Result
; // IsFini
elem: IfDefBrace:
^ IN aLambda
VAR l_WasIf
false >>> l_WasIf
Self nil .IfDefPrim: ( l_WasIf ! ? ( true >>> l_WasIf \n ) )
(
aLambda DO
l_WasIf ? \n
) // Self .IfDefPrim:
; // IfDefBrace:
elem: IfDefBraceLn:
^ IN aLambda
VAR l_WasIf
false >>> l_WasIf
Self nil .IfDefPrim: ( true >>> l_WasIf \n )
(
aLambda DO
l_WasIf ? \n
) // Self .IfDefPrim:
; // IfDefBraceLn:
BOOLEAN elem_func IsClassRef
Self .UPisTrue "isClassRef"
>>> Result
; // IsClassRef
ARRAY STRING TYPE ArrayOrString
STRING elem_func TypeInfo
RULES
( Self .IsNil )
'@tfw_tiVoid'
( Self .TypeName 'Tl3PCharLen' == )
'@tfw_tiWString'
( Self .IsString )
'@tfw_tiString'
( Self .TypeName 'Il3CString' == )
'@tfw_tiString'
( Self .TypeName 'Tl3WString' == )
'@tfw_tiString'
( Self .TypeName 'Tl3PCharLenPrim' == )
'@tfw_tiString'
( Self .IsRecord )
'@tfw_tiStruct'
( Self .IsClassRef )
'@tfw_tiClassRef'
DEFAULT
( [ 'TypeInfo(' Self .TypeName ')' ] strings:Cat )
; // RULES
>>> Result
; // TypeInfo
STRING elem_func PopSig
RULES
( Self .TypeName 'TClass' == )
'PopClass'
( Self .TypeName 'TtfwStackValue' == )
'Pop'
( Self .TypeName 'TClass' == )
'PopClass'
( Self .TypeName 'ItfwValueList' == )
'PopList'
( Self .TypeName 'ItfwFile' == )
'PopFile'
( Self .IsClassRef )
( [ 'PopClassAs(' Self .TypeName ')' ] strings:Cat )
( Self .TypeName 'Tl3WString' == )
'PopWStr'
( Self .TypeName 'Tl3PCharLenPrim' == )
'PopWStr'
( Self .TypeName 'Tl3PCharLen' == )
'PopWStr'
( Self .TypeName 'Il3CString' == )
'PopString'
( Self .IsSimpleClass )
( [ 'PopObjAs(' Self .TypeName ')' ] strings:Cat )
( Self .IsInterface )
( [ 'PopIntf(' Self .TypeName ')' ] strings:Cat )
( Self .TypeName 'String' == )
'PopDelphiString'
( Self .TypeName 'Char' == )
'PopChar'
( Self .TypeName 'AnsiChar' == )
'PopChar'
( Self .TypeName 'TPoint' == )
'PopPoint'
( Self .TypeName 'WideString' == )
'PopWideString'
( Self .TypeName 'AnsiString' == )
'PopDelphiString'
( Self .TypeName 'Integer' == )
'PopInt'
( Self .TypeName 'TColor' == )
'PopInt'
( Self .TypeName 'Cardinal' == )
'PopInt'
( Self .IsEnum )
'PopInt'
( Self .TypeName 'THandle' == )
'PopInt'
( Self .TypeName 'Boolean' == )
'PopBool'
( Self .IsTypedef )
( Self .MainAncestor call.me )
DEFAULT
( [ 'Не знаем как снять со стека : ' Self .TypeName ] strings:Cat )
; // RULES
>>> Result
; // PopSig
STRING elem_func PushType
RULES
( Self .TypeName 'ItfwValueList' == )
''
( Self .TypeName 'ItfwFile' == )
''
( Self .TypeName 'Il3CString' == )
''
( Self .IsInterface )
( [ ', ' 'TypeInfo(' Self .TypeName ')' ] strings:Cat )
DEFAULT
''
; // RULES
>>> Result
; // PushType
STRING elem_func PushSig
RULES
( Self .IsNil )
''
( Self .TypeName 'TClass' == )
'PushClass'
( Self .TypeName 'TtfwStackValue' == )
'Push'
( Self .TypeName 'TClass' == )
'PushClass'
( Self .TypeName 'ItfwValueList' == )
'PushList'
( Self .TypeName 'ItfwFile' == )
'PushFile'
( Self .IsClassRef )
'PushClass'
( Self .TypeName 'Tl3WString' == )
'PushString'
( Self .TypeName 'Tl3PCharLenPrim' == )
'PushString'
( Self .TypeName 'Tl3PCharLen' == )
'PushWStr'
( Self .TypeName 'Il3CString' == )
'PushString'
( Self .IsSimpleClass )
'PushObj'
( Self .IsInterface )
'PushIntf'
( Self .TypeName 'String' == )
'PushString'
( Self .TypeName 'Char' == )
'PushChar'
( Self .TypeName 'AnsiChar' == )
'PushChar'
( Self .TypeName 'TPoint' == )
'PushPoint'
( Self .TypeName 'WideString' == )
'PushWideString'
( Self .TypeName 'AnsiString' == )
'PushString'
( Self .TypeName 'Integer' == )
'PushInt'
( Self .TypeName 'TColor' == )
'PushInt'
( Self .TypeName 'Cardinal' == )
'PushInt'
( Self .IsEnum )
'PushInt'
( Self .TypeName 'THandle' == )
'PushInt'
( Self .TypeName 'Boolean' == )
'PushBool'
( Self .IsTypedef )
( Self .MainAncestor call.me )
DEFAULT
( [ 'Не знаем как положить на стек: ' Self .TypeName ] strings:Cat )
; // RULES
>>> Result
; // PushSig
STRING elem_func CastSig
RULES
( Self .TypeName 'ItfwValueList' == )
''
( Self .TypeName 'ItfwFile' == )
''
( Self .IsClassRef )
( Self .TypeName )
( Self .TypeName 'Tl3PCharLen' == )
( Self .TypeName )
( Self .IsSimpleClass )
( Self .TypeName )
( Self .IsInterface )
( Self .TypeName )
( Self .TypeName 'TColor' == )
( Self .TypeName )
( Self .TypeName 'Cardinal' == )
( Self .TypeName )
( Self .IsEnum )
( Self .TypeName )
( Self .TypeName 'THandle' == )
( Self .TypeName )
( Self .IsTypedef )
( Self .MainAncestor call.me )
DEFAULT
''
; // RULES
>>> Result
; // CastSig
STRING elem_func TypeValue
RULES
( Self .TypeName 'TtfwStackValue' == )
''
( Self .IsSimpleClass )
( [ '.AsObject(' Self .TypeName ')' ] strings:Cat )
( Self .TypeName 'Integer' == )
'.AsInt'
( Self .TypeName 'TColor' == )
'.AsInt'
( Self .TypeName 'Cardinal' == )
'.AsInt'
( Self .IsEnum )
'.AsInt'
( Self .TypeName 'String' == )
'.AsDelphiString'
( Self .TypeName 'AnsiString' == )
'.AsDelphiString'
( Self .TypeName 'Char' == )
'.AsChar'
( Self .TypeName 'AnsiChar' == )
'.AsChar'
( Self .TypeName 'Boolean' == )
'.AsBoolean'
( Self .IsTypedef )
( Self .MainAncestor call.me )
DEFAULT
( [ 'Не знаем как приводить значение типа ' Self .TypeName ] strings:Cat )
; // RULES
>>> Result
; // TypeValue
STRING elem_func UnCastSig
RULES
( Self .TypeName 'TColor' == )
'Integer'
( Self .TypeName 'Cardinal' == )
'Integer'
( Self .IsEnum )
'Ord'
( Self .TypeName 'THandle' == )
'Integer'
( Self .IsTypedef )
( Self .MainAncestor call.me )
DEFAULT
''
; // RULES
>>> Result
; // UnCastSig
elem_iterator BindServiceImplementationUC
[
Self .ImplementsInDependencies
.for> (
IN anItem
anItem .IfDefBrace:
(
cSpace anItem .TypeName '.Instance.Alien := ' Self .TypeName '.Instance;'
) // anItem .IfDefBrace:
) // Self .ImplementsInDependencies
]
>>> Result
; // BindServiceImplementationUC
elem_iterator RegAxiomUC
[ cSpace Self .TypeName '.Register;' ]
>>> Result
; // RegAxiomUC
BOOLEAN elem_func IsCustomChoice
Self .IsStereotype st_CustomChoice::Attribute
>>> Result
; // IsCustomChoice
BOOLEAN elem_func IsDefaultChoice
Self .IsStereotype st_DefaultChoice::Attribute
>>> Result
; // IsDefaultChoice
elem_iterator AdditionalInitCode
STRING IN aName
STRING elem_func ChoiceName
[
aName
//%C%f_pas_Prefix()%C#f_AdditionalPrefix()
'_Choice_'
Self .Name
] strings:Cat
>>> Result
; // ChoiceName
[
Self .Children
.filter> .IsChoices
.for> (
IN aChoices
aChoices .Children
.filter> .IsChoice
.for> (
IN aChoice
\n ' ' aName '.AddChoice(' aChoice .ChoiceName ');'
) // .for>
) // .for>
Self .Attributes
.filter> .IsCustomChoice
.for> (
IN aChoice
\n ' ' aName '.AddCustomChoice(' aChoice .Target .ChoiceName ');'
) // .for>
Self .Attributes
.filter> .IsDefaultChoice
.for> (
IN aChoice
\n ' ' aName '.AddDefaultChoice(' aChoice .Target .ChoiceName ');'
) // .for>
if ( Self .UPisTrue "NeedCheck" ) then
begin
\n ' ' aName '.SetNeedCheck(true);'
end // ( Self .UPisTrue "NeedCheck" )
VAR l_Value
Self .GetUP "CheckCaption" >>> l_Value
if ( l_Value .IsNotNil ) then
begin
\n ' ' aName '.SetCheckCaption(str_' Self .Name '_CheckCaption);'
end // ( l_Value .IsNotNil )
Self .GetUP "SettingsCaption" >>> l_Value
if ( l_Value .IsNotNil ) then
begin
\n ' ' aName '.SetSettingsCaption(str_' Self .Name '_SettingsCaption);'
end // ( l_Value .IsNotNil )
Self .GetUP "LongHint" >>> l_Value
if ( l_Value .IsNotNil ) then
begin
\n ' ' aName '.SetLongHint(str_' Self .Name '_LongHint);'
end // ( l_Value .IsNotNil )
\n ' ' aName '.SetDlgType(' 'mt' Self .GetUP "DlgType" ');'
]
>>> Result
; // AdditionalInitCode
PRINTABLE elem_func InitStrUCPrim
ModelElement IN aSpeller
[
VAR l_Name
[ Self .Parent .GetUP 'extprop:pas:ElementPrefix' Self .Name ] strings:Cat >>> l_Name
' ' l_Name '.Init;'
if ( aSpeller .IsMessage ) then
begin
aSpeller l_Name .AdditionalInitCode
end // ( aSpeller .IsMessage )
]
>>> Result
; // InitStrUCPrim
PRINTABLE elem_func InitStrUC
Self .SpelledFor Self .Speller .InitStrUCPrim
>>> Result
; // InitStrUC
PRINTABLE elem_func GetUserCode
STRING IN aKey
RULES
(
Self .IsIni
AND ( Self .IsSummoned )
)
(
VAR l_Parent
Self .Parent >>> l_Parent
RULES
( l_Parent .IsServiceImplementation )
( l_Parent .BindServiceImplementationUC )
( Self .Name 'Ini_Reg' == )
[ cSpace l_Parent .TypeName '.RegisterInEngine;' ]
( Self .Name 'RegAxiom' == )
( l_Parent .RegAxiomUC )
( Self .Name 'Ini_Reg_Class' == )
[
if ( l_Parent GarantModel::TtfwWord .InheritsFrom ) then
begin
' ' l_Parent .TypeName '.RegisterClass;'
end
else
begin
' TtfwClassRef.Register(' l_Parent .TypeName ');'
end
]
(
( 'Init_Str_' Self .Name StartsStr )
AND ( Self .SpelledFor .IsNotNil )
)
( Self .InitStrUC )
(
( 'Ini_FormFactory_' Self .Name StartsStr )
AND ( Self .SpelledFor .IsNotNil )
)
[
VAR l_SpelledFor
Self .SpelledFor >>> l_SpelledFor
' ' 'fm_' l_SpelledFor .TypeName .CutT '.SetFactory(' l_SpelledFor .TypeName '.Make);'
]
(
( 'Reg_Type_' Self .Name StartsStr )
AND ( Self .SpelledFor .IsNotNil )
)
[
VAR l_SpelledFor
Self .SpelledFor >>> l_SpelledFor
' TtfwTypeRegistrator.RegisterType('
l_SpelledFor .TypeInfo
');'
]
DEFAULT
'!!! Lost ini !!!'
; // RULES
)
(
Self .IsFini
AND ( Self .IsSummoned )
)
'!!! Lost fini !!!'
DEFAULT
( Self aKey cEmptyStr .ElemMember )
; // RULES
>>> Result
; // GetUserCode
BOOLEAN elem_func IsConstructorsHolder
( Self .MainAncestor .IsNotNil )
AND ( Self .Attributes .IsEmpty )
AND ( Self .OperationsEx .filter> ( .IsConstructor ! ) .IsEmpty )
>>> Result
; // IsConstructorsHolder
ModelElement elem_func MethodType
Cached:
(
RULES
( Self .InTie )
RULES
( Self .Target .TypeName 'Boolean' == )
GarantModel::ByteBool
DEFAULT
( Self .Target )
; // RULES
( Self .IsInternalOperation )
RULES
( Self .OpModify opModifyExecute == )
( Self .Target )
DEFAULT
nil
; // RULES
( Self .IsVCMOperationPrim )
nil
( Self .IsIterator )
(
RULES
( Self .MainAncestor .IsNotNil )
( Self .MainAncestor call.me )
( Self .UPisTrue "needs result" )
(
VAR l_Type
Self .Attributes
.filter> .IsResultType
.mapToTarget>
.FirstElement >>> l_Type
RULES
( l_Type .IsNotNil )
l_Type
DEFAULT
GarantModel::Integer
; // RULES
)
DEFAULT
nil
; // RULES
)
( Self .IsStaticConstructor )
if ( Self .Parent .IsConstructorsHolder ) then
( Self .Parent .MainAncestor )
else
( Self .Parent )
( Self .IsControlOverride )
( Self .MainAncestor call.me )
( Self .IsControlPrim )
( Self .MainAncestor )
( Self .IsStereotype st_Area )
( Self .MainAncestor )
( Self .IsConstructor )
nil
( Self .IsMethod )
RULES
( Self .ImplementsIterator )
( Self .MainImplements call.me )
( Self .MainAncestor .IsNotNil )
( Self .MainAncestor call.me )
DEFAULT
( Self .FirstOperation .Target )
; // RULES
( Self .IsFunction )
( Self .FirstOperation .Target )
DEFAULT
( Self .Target )
; // RULES
VAR l_Type
>>> l_Type
RULES
( l_Type .IsNil )
begin
RULES
( Self .IsStereotype st_factory::Operation )
( Self .Parent .MainImplementsInterface )
( Self .IsFactoryMethod )
( Self .MainImplementsInterface )
DEFAULT
l_Type
; // RULES
end // ( l_Type .IsNil )
DEFAULT
l_Type
; // RULES
>>> l_Type
RULES
( l_Type .IsNil )
begin
RULES
( Self .IsStereotype st_factory::Operation )
( 'BadFactoryType' )
( Self .IsFactoryMethod )
( Self .Parent .MainImplementsInterface )
DEFAULT
l_Type
; // RULES
end // ( l_Type .IsNil )
DEFAULT
l_Type
; // RULES
)
>>> Result
; // MethodType
BOOLEAN elem_func IsAcceptableForScripts
Self .UPisTrue 'extprop:rc:isAcceptableForScripts'
>>> Result
; // IsAcceptableForScripts
BOOLEAN elem_func InheritsOrImplementsAcceptableForScripts
Cached:
(
RULES
( Self .InheritsEx .filter> .IsAcceptableForScripts .NotEmpty )
true
( Self .ImplementsEx .filter> .IsAcceptableForScripts .NotEmpty )
true
DEFAULT
false
; // RULES
)
>>> Result
; // InheritsOrImplementsAcceptableForScripts
BOOLEAN elem_func HasSelf
RULES
( Self .Parent .InheritsOrImplementsAcceptableForScripts ! )
false
( Self .IsCreator )
false
( Self .IsKeyWord )
true
DEFAULT
false
; // RULES
>>> Result
; // HasSelf
BOOLEAN elem_func IsOutParam
Self .IsStereotype st_out >>> Result
; // IsOutParam
ARRAY FUNCTION .filterOutParam>
ARRAY IN anArray
anArray
.filter> ( .IsOutParam ! )
>>> Result
; // .filterOutParam>
STRING FUNCTION .UpperFirstChar
STRING IN aSubstr
RULES
( aSubstr .IsNil )
''
DEFAULT
begin
[
1 0 aSubstr string:Substring string:Upper
VAR l_Len
aSubstr string:Len 1 - >>> l_Len
l_Len < 0 ?FAIL 'l_Len < 0'
if ( l_Len > 0 ) then
begin
VAR l_Tail
l_Len
1 aSubstr string:Substring >>> l_Tail
l_Tail .IsNil ?FAIL 'l_Tail .IsNil'
l_Tail
end // ( l_Len > 0 )
] strings:Cat
end // DEFAULT
; // RULES
>>> Result
; // .UpperFirstChar
STRING FUNCTION .FromTie
STRING IN aValue
'' >>> Result
if ( aValue .IsNotNil ) then
begin
aValue cUnderline string:Split:for> (
IN aSubstr
aSubstr .IsNil ?FAIL 'aSubstr .IsNil'
[
Result
aSubstr .UpperFirstChar
] strings:Cat >>> Result
) // aValue cUnderline string:Split:for>
end // ( aValue .IsNotNil )
; // .FromTie
STRING FUNCTION .ToBorland
STRING IN aValue
'' >>> Result
aValue cUnderline string:Split:for> (
IN aSubstr
/*{ if ( aSubstr .IsNil ) then
begin
Result cUnderline Cat >>> Result
end
else}*/
begin
Result aSubstr Cat >>> Result
end
)
; // .ToBorland
STRING elem_func MethodName
STRING elem_func FineName
Self .Name '__' cUnderline string:Replace
>>> Result
; // FineName
Cached:
(
RULES
( Self .IsNil )
''
( Self .InTie )
( Self .Name .FromTie )
( Self .IsVCMOperationPrim )
RULES
( Self .IsTester )
( [ Self .Parent .Name cUnderline Self .Name '_Test' ] strings:Cat )
( Self .IsExecutor )
( [ Self .Parent .Name cUnderline Self .Name '_Execute' ] strings:Cat )
( Self .IsGetState )
( [ Self .Parent .Name cUnderline Self .Name '_GetState' ] strings:Cat )
DEFAULT
( [ Self .Parent .Name cUnderline Self .Name ] strings:Cat )
; // RULES
( Self .IsIterator )
(
RULES
( Self .IsIteratorF )
( Self .Name 'F' Cat )
( Self .MainAncestor .IsNotNil )
( Self .MainAncestor call.me )
DEFAULT
( Self .Name )
; // RULES
) // ( Self .IsIterator )
( Self .IsStaticConstructor )
if ( Self .Parent .IsConstructorsHolder ) then
( [ Self .Parent .MainAncestor .TypeName cUnderline Self .Name ] strings:Cat )
else
( [ Self .Parent .TypeName cUnderline Self .Name ] strings:Cat )
( Self .UPisTrue 'extprop:isGlobal' )
( Self .Name .ToBorland )
( Self .Parent .IsUtilityPack )
(
VAR l_Prefix
Self .Parent .GetUP 'extprop:pas:ElementPrefixBase' >>> l_Prefix
if ( l_Prefix .IsNil ) then
begin
Self .Parent .GetUP 'extprop:pas:ElementPrefix' >>> l_Prefix
end // ( l_Prefix .IsNil )
l_Prefix Self .FineName Cat
)
( Self .IsMethodAndImplementsIterator )
RULES
( Self .IsIteratorF )
( Self .MainImplements call.me 'F' Cat )
DEFAULT
( Self .MainImplements call.me )
; // RULES
( '__' Self .Name StartsStr )
( Self .FineName )
DEFAULT
( Self .FineName )
; // RULES
)
>>> Result
; // MethodName
elem_proc UserCode:
^ IN aSuffix
^ IN aCode
STRING VAR l_Key
aSuffix DO >>> l_Key
VAR l_Code
Self cUserCodePrefix l_Key Cat .GetUserCode >>> l_Code
if ( l_Code .IsValueValid ) then
begin
if ( l_Code cEmptyUserCode ?!= ) then
begin
l_Code .Out
end // ( l_Code cEmptyUserCode ?!= )
end // ( l_Code .IsValueValid )
else
begin
: AsDefault
Self l_Key l_Key aCode .DefaultUserCode
; // AsDefault
: AsMethod
Self l_Key aCode .MethodUserCode
; // AsMethod
VAR l_Implementor
Self .ImplementorOrParent >>> l_Implementor
BOOLEAN FUNCTION IsUID
STRING IN anUID
( Self .LUID anUID == )
AND ( l_Implementor .IsSummoned ) >>> Result
; // IsUID
: Pair:
^ IN aVar
^ IN aCode
RULES
( l_Key cVarUserCodeSuffix == )
( aVar DO )
( l_Key cImplementationUserCodeSuffix == )
( aCode DO )
DEFAULT
AsDefault
; // RULES
; // Pair:
: Code:
^ IN aCode
Pair: () ( aCode DO )
; // Code:
VAR l_Call
// - метод, который собственно надо звать из DoDoIt или DoRun.
l_Implementor .KeywordImplementationMethod >>> l_Call
VAR l_Op
l_Implementor .KeywordOperation >>> l_Op
VAR l_Self
l_Implementor .KeywordObjectToOperate >>> l_Self
elem_iterator ParametersWithoutContext
Self .Parameters
.filter> ( 'aCtx' .HasName ! )
>>> Result
; // ParametersWithoutContext
: .AsVar
STRING IN aName
ModelElement IN aType
'var' cSpace 'l_' aName ': ' aType .TypeName ';'
; // .AsVar
elem: ParamAsVar
Self .Name Self .Target .AsVar
; // ParamAsVar
: .Pop
STRING IN aName
ModelElement IN aType
'try' \n
' ' 'l_' aName
' := '
VAR l_CastSig
aType .CastSig >>> l_CastSig
if ( l_CastSig .IsNotNil ) then
begin
l_CastSig '('
end
'aCtx.rEngine.' aType .PopSig
if ( l_CastSig .IsNotNil ) then
begin
')'
end
';' \n
'except' \n
' on E: Exception do' \n
' begin' \n
' RunnerError(''Ошибка при получении параметра ' aName ': ' aType .TypeName ' : '' + E.Message, aCtx);' \n
' Exit;' \n
' end;//on E: Exception' \n
'end;//try..except' \n
; // .Pop
elem: ParamPop
Self .Name Self .Target .Pop
; // ParamPop
RULES
(
( Self .IsInternalOperation )
AND ( Self .OpModify opModifyNone == )
)
Code: (
Indented: (
[
if (
( Self .Target .IsNotNil )
OR ( Self .Parameters .NotEmpty )
) then
begin
'with (aParams.Data As I' Self .Parent .Name cUnderline Self .Name '_Params) do' \n ' '
end // ( Self .Target .IsNotNil ) ..
if ( Self .Target .IsNotNil ) then
begin
'ResultValue := '
end // ( Self .Target .IsNotNil )
'Self.' Self .MethodName '_Execute' Self .Parameters .map> ( .Name 'a' .CutPrefix ) .CommaListWith() ';'
] .Out
)
)
(
( Self .LUID '4DB6D7F70155' == ) // IsImmediate
AND ( l_Implementor .GetUP "is immediate" IsBool )
)
Code: ( [ ' Result := ' l_Implementor .GetUP "is immediate" ';' ] .Out )
(
( l_Op .IsNotNil )
AND ( GarantModel::TtfwCompilingWord.SuppressNextImmediate .LUID IsUID ) // SuppressNextImmediate
)
Code: ( [ ' Result := ' 'tfw_sni' l_Op .GetUP "SupressNextImmediate" ';' ] .Out )
(
( l_Op .IsNotNil )
AND ( GarantModel::TtfwString.GetString .LUID IsUID ) // GetString
)
Code:
(
if ( 'Слово словаря для идентификатора контрола' l_Implementor .Documentation StartsStr ) then
begin
[ ' Result := ' cQuote l_Op .Name cQuote ';' ] .Out
end
else
begin
[ ' Result := ' cQuote l_Op .TypeName .CutT cQuote ';' ] .Out
end
)
(
( l_Op .IsNotNil )
AND ( l_Self .IsNotNil )
AND ( GarantModel::TtfwWord.SetValuePrim .LUID IsUID ) // SetValuePrim
)
Pair:
(
if ( l_Op .GetUP 'extprop:prop_stereo' 'readonly' != ) then
begin
if ( l_Self .IsNotNil ) then
begin
[ l_Self .SelfName l_Self .AsVar ] .Out
end // ( l_Self .IsNotNil )
l_Op .Parameters
.filterOutParam>
.for> (
IN aParam
[ aParam .ParamAsVar ] .Out
) // .for>
end // ( l_Op .GetUP 'extprop:prop_stereo' 'readonly' != )
)
(
if ( l_Op .GetUP 'extprop:prop_stereo' 'readonly' == ) then
begin
[
' RunnerError(''Нельзя присваивать значение readonly свойству '
l_Op .GetUP 'extprop:prop_name'
''', aCtx);'
] .Out
end // ( l_Op .GetUP 'extprop:prop_stereo' 'readonly' == )
else
begin
Indented:
(
[
if ( l_Self .IsNotNil ) then
begin
l_Self .SelfName l_Self .Pop
end // ( l_Self .IsNotNil )
l_Op .Parameters
.filterOutParam>
.for> (
IN aParam
aParam .ParamPop
) // .for>
if ( l_Self .IsNotNil ) then
begin
if ( l_Op .UPisTrue "mapped" ) then
begin
'l_' l_Self .SelfName
cDot
l_Op .GetUP 'extprop:prop_name'
' := '
VAR l_CastSig
l_Op .Target .CastSig >>> l_CastSig
if ( l_CastSig .IsNotNil ) then
begin
l_CastSig '('
end
'aValue' l_Op .Target .TypeValue
if ( l_CastSig .IsNotNil ) then
')'
end // ( l_Op .UPisTrue "mapped" )
else
begin
'DoSetValue'
'('
'l_' l_Self .SelfName
l_Op .Parameters
.filterOutParam>
.for> (
IN aParam
', '
'l_'
aParam .Name
) // .for>
', '
VAR l_CastSig
l_Op .Target .CastSig >>> l_CastSig
if ( l_CastSig .IsNotNil ) then
begin
l_CastSig '('
end
'aValue' l_Op .Target .TypeValue
if ( l_CastSig .IsNotNil ) then
')'
')'
end
';'
end // ( l_Self .IsNotNil )
] .Out
) // Indented:
end // ( l_Op .GetUP 'extprop:prop_stereo' 'readonly' == )
)
(
( l_Call .IsNotNil )
AND
(
( GarantModel::TtfwWordPrim.DoDoIt .LUID IsUID ) // DoDoIt
OR ( GarantModel::TtfwAnonimousWord.DoRun .LUID IsUID ) // DoRun
)
)
Pair:
(
l_Call .ParametersWithoutContext
.for> (
IN aParam
[ aParam .ParamAsVar ] .Out
) // .for>
)
(
Indented:
(
[
l_Call .ParametersWithoutContext
.filterOutParam>
.for> (
IN aParam
aParam .ParamPop
) // .for>
VAR l_PushSig
l_Call .Target .PushSig >>> l_PushSig
VAR l_UnCastSig
'' >>> l_UnCastSig
if ( l_PushSig .IsNotNil ) then
begin
'aCtx.rEngine.' l_PushSig '('
l_Call .Target .UnCastSig >>> l_UnCastSig
if ( l_UnCastSig .IsNotNil ) then
begin
l_UnCastSig '('
end // ( l_UnCastSig .IsNotNil )
end
l_Call .MethodName
'('
'aCtx'
l_Call .ParametersWithoutContext
.for> (
IN aParam
', ' 'l_' aParam .Name
) // .for>
')'
if ( l_PushSig .IsNotNil ) then
begin
if ( l_UnCastSig .IsNotNil ) then
begin
')'
end // ( l_UnCastSig .IsNotNil )
l_Call .Target .PushType
')'
end
';'
l_Call .ParametersWithoutContext
.filter> ( .IsOutParam )
.reverted>
.for> (
IN aParam
\n
'aCtx.rEngine.'
aParam .Target .PushSig
'('
'l_' aParam .Name
aParam .Target .PushType
')'
';'
) // .for>
] .Out
) // Indented:
)
(
( l_Op .IsNotNil )
AND ( GarantModel::TtfwRegisterableWordPrim.RegisterInEngine .LUID IsUID ) // RegisterInEngine
)
Code:
(
[
' inherited;' \n
' TtfwClassRef.Register('
if ( l_Op .IsControlPrim ) then
begin
l_Op .MethodType .TypeName
end // ( l_Op .IsControlPrim )
else
begin
l_Op .TypeName
end // ( l_Op .IsControlPrim )
')' ';'
] .Out
)
(
( l_Op .IsNotNil )
AND ( GarantModel::TtfwWordPrim.DoDoIt .LUID IsUID ) // DoDoIt
AND ( l_Implementor GarantModel::TkwBynameControlPush .InheritsFrom )
)
Code:
(
[
' aCtx.rEngine.PushString(' cQuote l_Op .Name cQuote ')' ';' \n
' inherited;'
] .Out
)
( GarantModel::TtfwWord.ParamsTypes .LUID IsUID ) // ParamsTypes
Code:
(
VAR l_NeedComma
false >>> l_NeedComma
[
' Result := '
'OpenTypesToTypes'
'('
'['
if ( l_Self .IsNil ) then
[empty]
else
[ l_Self ]
.join>
(
l_Op .Parameters
.filterOutParam>
.mapToTarget>
) // .join>
.map> .TypeInfo
.for> (
.WithComma: l_NeedComma .KeepInStack
)
']'
')'
';'
] .Out
) // ( l_Key cImplementationUserCodeSuffix == )
( GarantModel::TtfwWord.GetResultTypeInfo .LUID IsUID ) // GetResultTypeInfo
Code:
(
[
' Result := '
if ( l_Op .IsCreator ) then
begin
l_Self .TypeInfo
end // ( l_Op .IsCreator )
else
begin
l_Op .Target .TypeInfo
end // ( l_Op .IsCreator )
';'
] .Out
) // ( l_Key cImplementationUserCodeSuffix == )
( GarantModel::TtfwWord.GetAllParamsCount .LUID IsUID ) // GetAllParamsCount
Code:
(
[
' Result := '
l_Op .Parameters
.filterOutParam>
.CountIt
l_Op .HasSelf ? ( 1 + )
l_Op .IsVarWorker ? ( 1 + )
';'
] .Out
) // ( l_Key cImplementationUserCodeSuffix == )
( GarantModel::TtfwWord.RightParamsCount .LUID IsUID ) // RightParamsCount
Code:
( ' Result := 1;' .Out )
( GarantModel::TtfwClassLike.BindParams .LUID IsUID )
Code:
( ' Result := true;' .Out )
(
( Self .LUID '4B7AB0B6016E' == ) // TTestResultsPlace.CommandLineKey
AND ( Self .OpKind opkind_Normal != )
)
Code:
( [ ' Result := ' cQuote '-' l_Implementor .Name 'Release' .CutPrefix cQuote ';' ] .Out )
( Self .IsFactory )
begin
Pair:
(
if ( Self .Parent .IsSingleton ! ) then
begin
'var' .Out
[ ' l_Inst : ' Self .Parent .TypeName ';' ] .Out
end // ( Self .Parent .IsSingleton ! )
)
(
if ( Self .Parent .IsSingleton ) then
begin
Indented: (
[
VAR l_TypeName
Self .Parent .TypeName >>> l_TypeName
'if (' 'g_' l_TypeName ' = nil) then' \n
'begin' \n
' l3System.AddExitProc(' l_TypeName 'Free' ');' \n
VAR l_Type
Self .MethodType .TypeName >>> l_Type
' ' l_Type '(' 'g_' l_TypeName ')' ' := inherited ' Self .Name ';' \n
'end;' \n
'Result := ' l_Type '(' 'g_' l_TypeName ')' ';'
] .Out
) // Indented:
end // ( Self .Parent .IsSingleton )
else
begin
Indented: (
[
'l_Inst := '
VAR l_CallTo
Self .MainAncestor >>> l_CallTo
if ( l_CallTo .IsNil ) then
'Create'
else
begin
l_CallTo .Name
end // ( l_CallTo .IsNil )
Self .ParametersList ';'
] .Out
'try' .Out
[
' Result := '
if (
( Self .MethodType .IsMixInParamType )
AND ( Self .Parent .IsMixIn )
) then
'_Instance_R_(l_Inst)'
else
'l_Inst'
if ( Self .UPisTrue "need As" ) then
begin
' As ' Self .MethodType .TypeName
end // ( Self .UPisTrue "need As" )
';'
] .Out
'finally' .Out
' l_Inst.Free;' .Out
'end;//try..finally' .Out
) // Indented:
end // ( Self .Parent .IsSingleton )
)
end // ( Self .IsFactory )
(
( Self .OpKind opkind_Normal == ) // - метод новый, а не перекрытый
AND ( l_Op .IsNotNil )
AND ( l_Self .IsNotNil )
AND ( l_Implementor .IsSummoned )
AND ( l_Op .UPisTrue "mapped" )
)
Code:
(
[
' '
if ( Self .Target .IsNotNil ) then
begin
'Result := '
end
'a' l_Self .SelfName cDot l_Op .Name l_Op .ParametersList ';'
] .Out
)
(
'ResNameGetter' Self .Name EndsStr
AND ( Self .IsSimpleClass )
)
RULES
( l_Key 'impl' == )
( [ cSpace cOpenComment '$R ' Self .EffectiveUnitName '.res' cCloseComment ] .Out )
DEFAULT
()
; // RULES
( Self .IsElementProxy )
AsDefault
( Self .IsClassOrMixIn )
AsDefault
( Self .IsRecord )
AsDefault
( Self .IsUtilityPack )
AsDefault
( Self .IsTarget )
AsDefault
( Self .IsIni )
AsDefault
( Self .IsFini )
AsDefault
( Self .IsInterfaces )
AsDefault
DEFAULT
AsMethod
; // RULES
end // ( l_Code .IsValueValid )
; // UserCode:
ARRAY FUNCTION .mapToUnitProducer>
ARRAY IN anArray
anArray
.map> .UnitProducer
.filterNil>
.filterMixIns>
>>> Result
; // .mapToUnitProducer>
elem_proc OutUses:
STRING IN aUCPrefix
^ IN aUsed
^ IN aLambda
^ IN anItemTransform
ARRAY VAR l_Used
aUsed DO >>> l_Used
ARRAY FUNCTION .filterUsed>
ARRAY IN anArray
anArray
.filter> (
IN anItem
anItem .UnitName >>> anItem
if ( anItem .NotInArray: l_Used ) then
begin
anItem .AddToArray: l_Used
true
end
else
begin
false
end
) >>> Result
; // .filterUsed>
'uses' .Out
VAR l_NeedComma
false >>> l_NeedComma
Indented: (
aLambda DO
.mapToUnitProducer>
.filter> ( Self ?!= )
.filter> ( .UnitName Self .UnitName ?!= )
.filter> ( .UnitName 'System' ?!= )
.filterUsed>
.for> (
IN anItem
anItem .IfDef: ( anItem anItemTransform DO .WithComma: l_NeedComma .Out )
) // .for>
if (
( Self .IsElementProxy )
OR ( Self .UPisTrue "need UC" )
) then
begin
Self .UserCode: aUCPrefix ()
end // ( Self .IsElementProxy )
if (
( aUCPrefix 'intf_uses' == )
AND ( Self .UPisTrue "need UC in project" )
) then
begin
Self .UserCode: 'manualuses' ()
end // ( Self .IsElementProxy )
) // Indented:
';' .Out
OutLn
; // OutUses:
ARRAY FUNCTION .mapToTargetAndValueType>
ARRAY IN anArray
anArray .mapToTarget>
.join> ( anArray .map> .ValueType )
>>> Result
; // .mapToTargetAndValueType>
elem_iterator AttributesAndOperations
Cached:
(
Self .Attributes
.join> ( Self .OperationsEx )
.filter> ( .IsSomeKeyWord ! )
.filter> ( .IsStereotype st_link::Attribute ! )
)
>>> Result
; // AttributesAndOperations
INTERFACE FUNCTION MakeIniProcedure:
STRING IN aName
^ IN aLambda
aName MakeProcedure: (
IN aMade
aMade -> Stereotype := st_ini::Operation
aMade -> Visibility := PrivateAccess
aMade aLambda DO
) // MakeProcedure:
>>> Result
; // MakeIniProcedure:
BOOLEAN elem_func IsFriend
Self .IsStereotype st_friend::Dependency
>>> Result
; // IsFriend
elem_iterator FriendInDependencies
Cached:
(
Self .Dependencies
.filter> .IsFriend
.mapToTarget>
array:Copy
)
>>> Result
; // FriendInDependencies
BOOLEAN elem_func NeedsScript
RULES
( Self .UPisTrue "needs script" )
true
( Self .UPisTrue "noRegistrator" )
false
DEFAULT
RULES
( Self .IsScriptKeywordsPack )
RULES
( Self .IsSummoned )
false
( Self .Parent .IsVCMForm )
false
( Self .Parent .IsVCMFormsPack )
false
( Self .UPisTrue "no class name" )
true
( Self .UPisTrue "no_pop" )
true
DEFAULT
false
; // RULES
DEFAULT
false
; // RULES
; // RULES
>>> Result
; // NeedsScript
ModelElement elem_func ClassForKeywordImplementation
ModelElement IN aKeywordSelf
ModelElement IN aPack
VAR l_ClassName
[
if ( aKeywordSelf .NotIsNil ) then
begin
if (
( aPack .UPisTrue "no_pop" ! )
AND ( Self .IsCreator ! )
) then
begin
'pop_'
end // ( Self .UPisTrue "no_pop" ! )
if (
( aPack .UPisTrue "no class name" ! )
AND ( aKeywordSelf .SelfName 'SV' != )
) then
begin
aKeywordSelf .SelfName '_'
end // ( Self .UPisTrue "no class name" ! )
end // ( aKeywordSelf .NotIsNil )
Self .Name
] strings:Cat
>>> l_ClassName
l_ClassName
RULES
( Self .IsVarWorker )
GarantModel::TtfwWordWorkerEx
( Self .IsGlobalKeyWord )
GarantModel::TtfwGlobalKeyWord
( Self .GetUP 'extprop:prop_stereo' .IsValueValid )
GarantModel::TtfwPropertyLike
DEFAULT
GarantModel::TtfwClassLike
; // RULES
MakeClass: (
IN aMade
VAR l_WordName
Self .NameForScript >>> l_WordName
if ( l_WordName .IsNil ) then
begin
l_ClassName cUnderline ':' string:Replace >>> l_WordName
end // ( l_WordName .IsNil )
aMade -> UID := (
[
Self .LUID
if ( aKeywordSelf .NotIsNil ) then
begin
cUnderline aKeywordSelf .LUID
end // ( aKeywordSelf .NotIsNil )
'_Word'
] strings:Cat
)
aMade -> %SUM := ( 'Слово скрипта ' l_WordName Cat )
aMade -> Parent := ( Self .Parent .WeakRef )
aMade -> Stereotype := st_ScriptKeyword
aMade -> Visibility := PrivateAccess
aMade -> Abstraction := at_final
aMade -> SpelledFor := ( Self .WeakRef )
aMade -> Speller := ( aKeywordSelf .WeakRef )
aMade -> "is immediate" := ( Self .GetUP "is immediate" )
aMade -> "ifdef" := ( Self .IfDefStr )
aMade -> "ifndef" := ( Self .IfNDefStr )
aMade -> "NameForScript" := l_WordName
aMade -> 'extprop:pas:TypeName' := (
[
'T' 'kw'
//l_ClassName 'kw' .CutPrefix cUnderline '' string:Replace .UpperFirstChar
l_ClassName 'kw' .CutPrefix .FromTie
] strings:Cat
)
aMade -> IsSummoned := true
// - это вообще говоря "времянка", чтобы Override методы выводили код
) // MakeClass:
VAR l_Made
>>> l_Made
if ( Self .Speller .IsNil ) then
// - здесь вообще говоря надо массив Speller'ов, и учесть его ниже, где алиасы выводятся
begin
Self -> Speller := l_Made
end // ( Self .Speller .IsNil )
l_Made
>>> Result
; // ClassForKeywordImplementation
elem_iterator ChildrenEx
Cached:
(
VAR l_Children
Self .Children >>> l_Children
Self .FriendInDependencies
.filter> ( .IsEvdSchemaElement ! )
.filter> ( .IsInterface ! )
.map> .FriendClass
.filter> ( l_Children SWAP .Name .HasModelElementWithName ! )
.for> (
IN aFriend
l_Children
.join> ToArray: aFriend
array:Copy
>>> l_Children
) // .for>
if ( Self .IsScriptKeywordsPack ) then
begin
: .OperationsToClasses
ARRAY IN anOps
ModelElement IN aKeywordSelf
anOps
//.filter> ( .Name Msg true )
.map> ( aKeywordSelf Self .ClassForKeywordImplementation )
.filter> ( l_Children SWAP .Name .HasModelElementWithName ! )
.for> (
IN aClass
l_Children
.join> ToArray: aClass
array:Copy
>>> l_Children
) // .for>
; // .OperationsToClasses
Self .OperationsEx
.filter> .IsGlobalKeyWord
nil
.OperationsToClasses
Self .InheritsEx
.join> ( Self .ImplementsEx )
.filter> .IsAcceptableForScripts
.for> (
IN aG
Self .OperationsEx
.filter> .IsKeyWord
aG
.OperationsToClasses
) // .for>
Self .InheritsEx
.filter> .IsVCMForm
.filter> ( .Abstraction at_final == )
.for> (
IN aForm
begin
VAR l_ClassName
[ 'Tkw_Form_' aForm .Name ] strings:Cat >>> l_ClassName
if ( l_Children l_ClassName .HasModelElementWithName ! ) then
begin
l_Children
.join> ToArray: (
l_ClassName
GarantModel::TtfwControlString
MakeClass: (
IN aMade
aMade -> UID := ( [ aForm .LUID '_Word' ] strings:Cat )
aMade -> Parent := ( Self .WeakRef )
aMade -> "NameForScript" := (
[ 'форма::' aForm .Name ' ' '_' string:Replace ] strings:Cat
) // aMade -> "NameForScript"
aMade -> %SUM := (
[
'Слово словаря для идентификатора формы ' aForm .Name \n
'----' \n
'*Пример использования*:' \n
'{code}'
aMade .NameForScript
' TryFocus ASSERT'
'{code}'
] strings:Cat
) // aMade -> %SUM
aMade -> Visibility := PrivateAccess
aMade -> Abstraction := at_final
aMade -> SpelledFor := ( aForm .WeakRef )
aMade -> Stereotype := st_ScriptKeyword
aMade -> "ifdef" := ( aForm .GetUP "ifdef" )
aMade -> "ifndef" := ( aForm .GetUP "ifndef" )
aMade -> IsSummoned := true
aMade -> Overridden := [
GarantModel::TtfwString.GetString .OverrideMethod
GarantModel::TtfwRegisterableWordPrim.RegisterInEngine .OverrideMethod
] // aMade -> Overridden
) // MakeClass:
) // .join> ToArray:
array:Copy
>>> l_Children
end // ( l_Children l_ClassName .HasModelElementWithName ! )
end // ( aForm .IsComponent ! )
aForm .CollectControls
//.filter> ( .Visibility PublicAccess == )
//.filter> ( .MainAncestor .NotIsNil )
.for> (
IN aControl
//if ( aControl .IsComponent ! ) then
begin
VAR l_ClassName
[ 'Tkw_' aForm .Name
'_'
if ( aControl .IsComponent ) then
'Component'
else
'Control'
'_' aControl .Name ] strings:Cat >>> l_ClassName
if ( l_Children l_ClassName .HasModelElementWithName ! ) then
begin
l_Children
.join> ToArray: (
l_ClassName
GarantModel::TtfwControlString
MakeClass: (
IN aMade
aMade -> UID := ( [ aControl .LUID '_Word' ] strings:Cat )
aMade -> Parent := ( Self .WeakRef )
aMade -> "NameForScript" := (
[
if ( aControl .IsComponent ) then
'компонент'
else
'контрол'
'::'
aControl .Name ' ' '_' string:Replace
] strings:Cat
) // aMade -> "NameForScript"
aMade -> %SUM := (
[
'Слово словаря для идентификатора контрола ' aControl .Name \n
'----' \n
'*Пример использования*:' \n
'{code}'
aMade .NameForScript
' TryFocus ASSERT'
'{code}'
] strings:Cat
) // aMade -> %SUM
aMade -> Visibility := PrivateAccess
aMade -> Abstraction := at_final
aMade -> SpelledFor := ( aControl .WeakRef )
aMade -> Stereotype := st_ScriptKeyword
aMade -> "ifdef" := ( aControl .GetUP "ifdef" )
aMade -> "ifndef" := ( aControl .GetUP "ifndef" )
aMade -> IsSummoned := true
aMade -> Overridden := [
GarantModel::TtfwString.GetString .OverrideMethod
GarantModel::TtfwRegisterableWordPrim.RegisterInEngine .OverrideMethod
] // aMade -> Overridden
) // MakeClass:
) // .join> ToArray:
array:Copy
>>> l_Children
end // ( l_Children l_ClassName .HasModelElementWithName ! )
end // ( aControl .IsComponent ! )
if ( aControl .IsComponent ! ) then
begin
VAR l_ClassName
[ 'Tkw_' aForm .Name
'_'
if ( aControl .IsComponent ) then
'Component'
else
'Control'
'_' aControl .Name '_Push' ] strings:Cat >>> l_ClassName
if ( l_Children l_ClassName .HasModelElementWithName ! ) then
begin
l_Children
.join> ToArray: (
l_ClassName
GarantModel::TkwBynameControlPush
MakeClass: (
IN aMade
aMade -> UID := ( [ aControl .LUID '_Word_Push' ] strings:Cat )
aMade -> Parent := ( Self .WeakRef )
aMade -> "NameForScript" := (
[
if ( aControl .IsComponent ) then
'компонент'
else
'контрол'
'::'
aControl .Name ' ' '_' string:Replace
':push'
] strings:Cat
) // aMade -> "NameForScript"
aMade -> %SUM := (
[
'Слово словаря для контрола ' aControl .Name \n
'----' \n
'*Пример использования*:' \n
'{code}'
aMade .NameForScript
' pop:control:SetFocus ASSERT'
'{code}'
] strings:Cat
) // aMade -> %SUM
aMade -> Visibility := PrivateAccess
aMade -> Abstraction := at_final
aMade -> SpelledFor := ( aControl .WeakRef )
aMade -> Stereotype := st_ScriptKeyword
aMade -> "ifdef" := ( aControl .GetUP "ifdef" )
aMade -> "ifndef" := ( aControl .GetUP "ifndef" )
aMade -> IsSummoned := true
aMade -> Overridden := [
GarantModel::TtfwWordPrim.DoDoIt .OverrideMethod
] // aMade -> Overridden
) // MakeClass:
) // .join> ToArray:
array:Copy
>>> l_Children
end // ( l_Children l_ClassName .HasModelElementWithName ! )
end // ( aControl .IsComponent ! )
) // .for>
) // .for>
end // ( Self .IsScriptKeywordsPack )
if ( Self .IsVCMForm ) then
begin
if ( Self .Abstraction at_final == ) then
begin
VAR l_PackName
[ Self .Name 'KeywordsPack' ] strings:Cat >>> l_PackName
if ( l_Children l_PackName .HasModelElementWithName ! ) then
if ( Self .Parent call.me l_PackName .HasModelElementWithName ! ) then
begin
l_Children
.join> ToArray: (
l_PackName
Self
MakeClass: (
IN aMade
aMade -> UID := ( [ Self .LUID '_Pack' ] strings:Cat )
aMade -> Parent := ( Self .WeakRef )
aMade -> %SUM := (
[
'Набор слов словаря для доступа к экземплярам контролов формы '
Self .Name
] strings:Cat
) // aMade -> %SUM
aMade -> Visibility := PublicAccess
aMade -> Abstraction := at_final
aMade -> SpelledFor := ( Self .WeakRef )
aMade -> Stereotype := st_ScriptKeywordsPack
aMade -> "ifdef" := ( Self .GetUP "ifdef" )
aMade -> "ifndef" := (
[ 'NoScripts' 'NoVCL' Self .GetUP "ifndef" ] ',' strings:CatSep
) // aMade -> "ifndef"
aMade -> IsSummoned := true
aMade -> "UseNewGen" := true
aMade -> "noRegistrator" := true
aMade -> "no_pop" := true
) // MakeClass:
) // .join> ToArray:
array:Copy
>>> l_Children
end // ( l_Children l_ClassName .HasModelElementWithName ! )
end // ( Self .Abstraction at_final == )
end // ( Self .IsVCMForm )
l_Children
if ( Self .IsTestClass ) then
begin
if ( Self .UPisTrue "is friend" ) then
begin
.join> ToArray: ( Self .MainAncestor .FriendClass )
end // ( Self .UPisTrue "is friend" )
end // ( Self .IsTestClass )
if ( Self .NeedsScript ) then
begin
STRING VAR l_ClassName
[ 'T' Self .UnitName 'ResNameGetter' ] strings:Cat >>> l_ClassName
if ( l_Children l_ClassName .HasModelElementWithName ! ) then
begin
.join>
[
l_ClassName GarantModel::TtfwAxiomaticsResNameGetter MakeClass: (
IN aMade
aMade -> UID := ( Self .LUID '_ResNameGetter' Cat )
aMade -> Parent := ( Self .WeakRef )
aMade -> Stereotype := st_SimpleClass
aMade -> %SUM := 'Регистрация скриптованой аксиоматики'
aMade -> Visibility := PrivateAccess
aMade -> Abstraction := at_final
aMade -> "ifdef" := ( Self .IfDefStr )
aMade -> "ifndef" := ( Self .IfNDefStr )
aMade -> "register in scripts" := false
aMade -> "need UC" := true
aMade -> Operations := [
'RegAxiom' MakeIniProcedure: (
IN aMadeIni
aMadeIni -> %SUM := 'Регистрация скриптованой аксиоматики'
aMadeIni .AddMethodWithParams: cUserCodePrefix aMade .RegAxiomUC
) // MakeIniProcedure:
] // aMade -> Operations
aMade -> Implemented := [
GarantModel::TtfwAxiomaticsResNameGetter.ResName .ImplementMethod
] // aMade -> Implemented
) // l_ClassName GarantModel::TtfwAxiomaticsResNameGetter MakeClass:
] // .join>
end // ( l_Children l_ClassName .HasModelElementWithName ! )
end // ( Self .NeedsScript )
.joinWithLambded> (
Self .OperationsEx
.filter> .IsIterator
.filter> ( .IsServiceIterator ! )
.filter> ( .IsOverride ! )
.filter> ( l_Children SWAP .IteratorAction .Name .HasModelElementWithName ! )
) ( .ToArray: .IteratorAction )
array:Copy
)
>>> Result
; // ChildrenEx
elem_iterator ChildrenWithoutOwnFile
Cached:
(
Self .ChildrenEx
.filter> ( .NeedOwnFile ! )
)
>>> Result
; // ChildrenWithoutOwnFile
elem_iterator ChildrenWithOwnFile
Cached:
(
Self .ChildrenEx
.filter> .NeedOwnFile
array:Copy
)
>>> Result
; // ChildrenWithOwnFile
INTERFACE FUNCTION MakeConstants:
STRING IN aName
^ IN aLambda
aName nil MakeParam: (
IN aMade
aMade -> Stereotype := st_Constants
aMade aLambda DO
)
>>> Result
; // MakeConstants:
INTERFACE FUNCTION MakeConstant:
STRING IN aName
PRINTABLE IN aValue
^ IN aLambda
aName nil MakeParam: (
IN aMade
aMade -> Class := class_Attribute
aMade -> 'extprop:pas:Value' := aValue
aMade aLambda DO
)
>>> Result
; // MakeConstant:
elem_iterator ConstantsEx
Cached:
(
Self .Constants
RULES
( Self .IsTypedef )
begin
VAR l_OtherEnum
Self .MainAncestor >>> l_OtherEnum
RULES
( l_OtherEnum .IsEnum )
RULES
( Self .Name l_OtherEnum .Name == )
RULES
( l_OtherEnum .Attributes .NotEmpty )
begin
VAR l_ConstantsName
[ Self .Name cUnderline l_OtherEnum .Name cUnderline 'Constants' ] strings:Cat >>> l_ConstantsName
RULES
(
Self .Parent call.me
.filter> ( .Name l_ConstantsName == )
.IsEmpty
)
begin
.join>
[
VAR l_ElementPrefix
l_OtherEnum .GetUP 'extprop:pas:ElementPrefix' >>> l_ElementPrefix
l_ConstantsName MakeConstants: (
IN aConstants
aConstants -> %SUM := ( [ 'Алиасы для значений ' l_OtherEnum .Parent .Name cDot l_OtherEnum .Name ] strings:Cat )
aConstants -> Visibility := PublicAccess
//aConstants -> 'extprop:pas:ElementPrefix' := l_ElementPrefix
aConstants -> Attributes := [
l_OtherEnum .Attributes .for> (
IN anItem
VAR l_Name
[ l_ElementPrefix anItem .Name ] strings:Cat >>> l_Name
l_Name
[ l_OtherEnum .EffectiveUnitName cDot l_Name ] strings:Cat
MakeConstant: (
IN aConstant
RULES
( anItem .Documentation .IsNotNil )
( aConstant -> %SUM := ( anItem .Documentation ) )
; // RULES
) // MakeConstant:
) // l_OtherEnum .Attributes .for>
] // aConstants -> Attributes
) // MakeConstants:
] // .join>
end
; // RULES
end // ( l_OtherEnum .Attributes .NotEmpty )
; // RULES
; // RULES
; // RULES
end // ( Self .IsTypedef )
; // RULES
array:Copy
)
>>> Result
; // ConstantsEx
elem_iterator ConstantsAndChildrenWithoutOwnFile
Cached:
(
Self .ConstantsEx
.join> ( Self .ChildrenWithoutOwnFile )
)
>>> Result
; // ConstantsAndChildrenWithoutOwnFile
elem_iterator AllOwnChildren
Cached:
(
Self .ConstantsAndChildrenWithoutOwnFile
.join> ( Self .AttributesAndOperations )
)
>>> Result
; // AllOwnChildren
ARRAY FUNCTION .OperationsNeededElements
ARRAY IN anArray
anArray .mapToTargetAndValueType>
.join> (
anArray
.filter> .IsMessageOperation
.filter> ( .GetUP "Message ID" 'CM_' SWAP StartsStr )
.map> ( DROP GarantModel::Controls )
) // .join>
.joinWithLambded> anArray ( .Parameters .mapToTargetAndValueType> )
.joinWithLambded> anArray ( .AttributesAndOperations call.me )
.joinWithLambded> ( anArray .filter> .IsFactoryMethod ) ( .MethodParameters .mapToTargetAndValueType> )
.joinWithLambded> ( anArray .filter> .IsIterator ) ( .MethodParameters .mapToTargetAndValueType> )
.joinWithLambded> ( anArray .filter> .IsFactoryMethod ) ( .ToArray: .MainImplementsInterface )
.joinWithLambded> ( anArray .filter> .IsMethod .map> .MainAncestor .filterNil> ) ( .MethodParameters .mapToTargetAndValueType> )
.joinWithLambded> ( anArray .filter> .IsMethod
.map> .MainAncestor
.filterNil>
.map> .MethodType
.filterNil> ) ( .ToArray )
.joinWithLambded> anArray .CanRaise
.joinWithLambded> anArray .CanRaiseInSet
>>> Result
; // .OperationsNeededElements
elem_iterator NeededElementsFromInheritsOrImplements
Cached:
(
( Self .InheritsEx )
.join> ( Self .ImplementsEx .filter> ( .IsEvdSchemaElement ! ) )
)
>>> Result
; // NeededElementsFromInheritsOrImplements
elem_iterator AttributesAndOperationsNeededElements
Self .AttributesAndOperations
.OperationsNeededElements
>>> Result
; // AttributesAndOperationsNeededElements
BOOLEAN elem_func InheritsFromOrSomeAncestorImplements
ModelElement IN anIntf
RULES
( Self anIntf .InheritsFrom )
true
( Self anIntf .SomeAncestorImplements )
true
DEFAULT
false
; // RULES
>>> Result
; // InheritsFromOrSomeAncestorImplements
BOOLEAN elem_func HasManagedAttributes
Cached:
(
RULES
( Self .IsNil )
false
DEFAULT
(
Self .Fields
.filter> .IsFieldForCleanup
.NotEmpty
)
; // RULES
)
>>> Result
; // HasManagedAttributes
BOOLEAN FUNCTION .HasModelElement
ARRAY IN anArray
ModelElement IN anElement
anArray .HasSomeOf: ( anElement .IsSameModelElement )
>>> Result
; // .HasModelElement
elem_iterator OverriddenEx
Cached:
(
VAR l_Overridden
Self .Overridden >>> l_Overridden
l_Overridden
if ( Self .IsClassOrMixIn ) then
begin
if ( Self .HasManagedAttributes ) then
begin
if ( Self GarantModel::l3UnknownPrim .InheritsFromOrSomeAncestorImplements ) then
begin
if ( l_Overridden GarantModel::l3UnknownPrim.ClearFields .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::l3UnknownPrim.ClearFields .OverrideMethod )
end // ( l_Overridden GarantModel::l3UnknownPrim.ClearFields .HasModelElement )
end // ( Self GarantModel::l3UnknownPrim .InheritsFromOrSomeAncestorImplements )
end // ( Self .HasManagedAttributes )
if ( Self .IsScriptKeyword ) then
begin
if ( Self .IsMixIn ! ) then
begin
if ( Self .Abstraction at_abstract != ) then
begin
if ( Self GarantModel::TtfwRegisterableWord .InheritsFromOrSomeAncestorImplements ) then
begin
if ( l_Overridden GarantModel::TtfwRegisterableWord.GetWordNameForRegister .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::TtfwRegisterableWord.GetWordNameForRegister .OverrideMethod )
end // ( l_Overridden GarantModel::TtfwRegisterableWord.GetWordNameForRegister .HasModelElement )
end // ( Self GarantModel::TtfwRegisterableWord .InheritsFromOrSomeAncestorImplements )
end // ( Self .Abstraction at_abstract != )
end // ( Self .IsMixIn ! )
BOOLEAN VAR l_HasDoIt
( l_Overridden
.join> ( Self .ImplementedEx )
GarantModel::TtfwWordPrim.DoDoIt .HasModelElement )
>>> l_HasDoIt
VAR l_Op
Self .KeywordOperation >>> l_Op
if (
( l_Op .IsNotNil )
AND ( l_Op .IsSomeKeyWord )
) then
begin
if (
( l_Op .GetUP "SupressNextImmediate" .IsNotNil )
AND ( l_Op .GetUP "SupressNextImmediate" 'None' != )
) then
begin
if ( l_Overridden GarantModel::TtfwCompilingWord.SuppressNextImmediate .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::TtfwCompilingWord.SuppressNextImmediate .OverrideMethod )
end // ( l_Overridden GarantModel::TtfwCompilingWord.SuppressNextImmediate .HasModelElement ! )
end // ( l_Op .GetUP "SupressNextImmediate" .IsNotNil )
if ( l_Overridden GarantModel::TtfwWord.GetResultTypeInfo .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::TtfwWord.GetResultTypeInfo .OverrideMethod )
end // ( l_Overridden GarantModel::TtfwWord.GetResultTypeInfo .HasModelElement ! )
if ( l_Overridden GarantModel::TtfwWord.GetAllParamsCount .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::TtfwWord.GetAllParamsCount .OverrideMethod )
end // ( l_Overridden GarantModel::TtfwWord.GetAllParamsCount .HasModelElement ! )
if ( l_Op .IsVarWorker ) then
begin
if ( l_Overridden GarantModel::TtfwWord.RightParamsCount .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::TtfwWord.RightParamsCount .OverrideMethod )
end // ( l_Overridden GarantModel::TtfwWord.RightParamsCount .HasModelElement ! )
end // ( l_Op .IsVarWorker )
if ( l_Op .UPisTrue "bind params" ) then
begin
if ( l_Overridden GarantModel::TtfwClassLike.BindParams .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::TtfwClassLike.BindParams .OverrideMethod )
end // ( l_Overridden GarantModel::TtfwClassLike.BindParams .HasModelElement ! )
end // ( l_Op .UPisTrue "bind params" )
if ( l_Overridden GarantModel::TtfwWord.ParamsTypes .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::TtfwWord.ParamsTypes .OverrideMethod )
end // ( l_Overridden GarantModel::TtfwWord.ParamsTypes .HasModelElement ! )
if (
( l_Op .GetUP 'extprop:prop_stereo' .IsValueValid )
OR ( l_Op .UPisTrue "lvalue" )
) then
begin
if ( l_Overridden GarantModel::TtfwWord.SetValuePrim .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::TtfwWord.SetValuePrim .OverrideMethod )
end // ( l_Overridden GarantModel::TtfwWord.SetValuePrim .HasModelElement ! )
end // ( l_Op .GetUP 'extprop:prop_stereo' .IsValueValid )
if ( l_Op .IsVarWorker ) then
begin
if ( l_Overridden GarantModel::TtfwAnonimousWord.DoRun .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::TtfwAnonimousWord.DoRun .OverrideMethod )
true >>> l_HasDoIt
end // ( l_Overridden GarantModel::TtfwAnonimousWord.DoRun .HasModelElement ! )
end // ( l_Op .IsVarWorker )
else
begin
if ( l_HasDoIt ! ) then
begin
.join> ToArray: ( GarantModel::TtfwWordPrim.DoDoIt .OverrideMethod )
true >>> l_HasDoIt
end // ( l_HasDoIt ! )
end // ( l_Op .IsVarWorker )
end // ( l_Op .IsNotNil )
if ( l_HasDoIt ! ) then
begin
if (
Self .InheritsEx
.filter> ( GarantModel::TtfwRegisterableWord .IsSameModelElement )
.NotEmpty
) then
begin
//Self .Name Msg
.join> ToArray: ( GarantModel::TtfwWordPrim.DoDoIt .OverrideMethod )
end // .filter> ( GarantModel::TtfwRegisterableWord .IsSameModelElement )
end // ( l_HasDoIt ! )
end // ( Self .IsScriptKeyword )
if ( Self .GetUP "is immediate" IsBool ) then
begin
if ( Self GarantModel::TtfwWord .InheritsFromOrSomeAncestorImplements ) then
begin
if ( l_Overridden GarantModel::TtfwWord.IsImmediate .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::TtfwWord.IsImmediate .OverrideMethod )
end // ( l_Overridden GarantModel::TtfwWord.IsImmediate .HasModelElement )
end // ( Self GarantModel::TtfwWord .InheritsFromOrSomeAncestorImplements )
end // ( Self .GetUP "is immediate" IsBool )
end // ( Self .IsClassOrMixIn )
if ( Self .IsTestCase ) then
begin
if ( Self GarantModel::TBaseTest .InheritsFromOrSomeAncestorImplements ) then
begin
if ( l_Overridden GarantModel::TAbstractTest.GetFolder .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::TAbstractTest.GetFolder .OverrideMethod )
end // ( l_Overridden GarantModel::TAbstractTest.GetFolder .HasModelElement )
if ( l_Overridden GarantModel::TAbstractTest.GetModelElementGUID .HasModelElement ! ) then
begin
.join> ToArray: ( GarantModel::TAbstractTest.GetModelElementGUID .OverrideMethod )
end // ( l_Overridden GarantModel::TAbstractTest.GetModelElementGUID .HasModelElement )
end // ( Self GarantModel::TBaseTest .InheritsFromOrSomeAncestorImplements )
end // ( Self .IsTestCase )
if ( Self .IsVCMApplication ) then
begin
.join> ToArray: ( GarantModel::TComponent.Loaded .OverrideMethod )
end // ( Self .IsVCMApplication )
)
>>> Result
; // OverriddenEx
elem_iterator ImplementedAndOverridden
Cached:
(
Self .ImplementedEx
.join> ( Self .OverriddenEx )
)
>>> Result
; // ImplementedAndOverridden
elem_iterator NeededElements
Cached:
(
if ( Self .IsScriptKeywordsPack ) then
begin
[empty]
end // ( Self .IsScriptKeywordsPack )
else
begin
Self .NeededElementsFromInheritsOrImplements
end // ( Self .IsScriptKeywordsPack )
.join> ( Self .AttributesAndOperationsNeededElements )
if ( Self .IsTypedef ! ) then
begin
.join> ( Self .ImplementedAndOverridden .OperationsNeededElements )
end // Self .IsTypedef !
if ( Self .IsClassOrMixIn ) then
begin
.joinWithLambded> ( Self .ClassImplementsPrim ) .InterfaceForClassImplements
end // ( Self .IsClassOrMixIn )
.joinWithLambded> ( Self .NeededElementsFromInheritsOrImplements .filter> .IsMixIn ) call.me
Self .NeededElementsFromInheritsOrImplements .filter> .IsMixIn .for> (
IN anItem
.joinWithLambded> ( anItem .ConstantsAndChildrenWithoutOwnFile ) call.me
)
)
>>> Result
; // NeededElements
elem_iterator NeededElements:
^ IN aChildAcceptable
if ( Self aChildAcceptable DO ) then
begin
Self .NeededElements
end // ( Self aChildAcceptable DO )
else
[empty]
>>> Result
; // NeededElements:
elem_iterator NeededElementsTotal
IN aChildAcceptable
[empty]
.joinWithLambded> ( Self .ConstantsAndChildrenWithoutOwnFile .filter> ( aChildAcceptable DO ) ) .NeededElements
.joinWithLambded> ( Self .ConstantsAndChildrenWithoutOwnFile ) ( aChildAcceptable call.me )
>>> Result
; // NeededElementsTotal
elem_iterator NeededElementsTotal:
^ IN aChildAcceptable
Self aChildAcceptable .NeededElementsTotal
>>> Result
; // NeededElementsTotal:
BOOLEAN elem_func IsForInterfacePrim
Cached:
(
RULES
( Self .Visibility PublicAccess == )
true
( Self .Visibility ProtectedAccess == )
true
DEFAULT
false
; // RULES
)
>>> Result
; // IsForInterfacePrim
BOOLEAN elem_func IsForInterface
Cached:
(
RULES
( Self .Parent .IsNotNil )
RULES
( Self .Parent call.me )
( Self .IsForInterfacePrim )
DEFAULT
false
; // RULES
( Self .IsForInterfacePrim )
true
DEFAULT
false
; // RULES
)
>>> Result
; // IsForInterface
BOOLEAN elem_func IsForImplementation
Cached:
(
Self .IsForInterface !
)
>>> Result
; // IsForImplementation
BOOLEAN elem_func IsVCMControls
Self .IsStereotype st_VCMControls
>>> Result
; // IsVCMControls
elem_iterator DependsEx
Cached:
(
Self .Depends
array:Copy
)
>>> Result
; // DependsEx
elem_iterator IntfUses
Cached:
(
GarantModel::l3IntfUses .ToArray
if ( Self .IsInterfaces ) then
begin
.join> ( Self .DependsEx .filter> .IsInterfaces )
end // ( Self .IsInterfaces )
.join> ( Self .NeededElements: .IsForInterface )
.join> ( Self .NeededElementsTotal: .IsForInterface )
if ( Self .IsControllerInterfaces ) then
begin
.join> ToArray: GarantModel::vcmInterfaces
.join> ToArray: GarantModel::vcmControllers
end // ( Self .IsControllerInterfaces )
if ( Self .IsVCMControls ) then
begin
.join> ToArray: GarantModel::vcmExternalInterfaces
end // ( Self .IsVCMControls )
)
>>> Result
; // IntfUses
BOOLEAN elem_func IsInjects
Self .IsStereotype st_injects::Dependency
>>> Result
; // IsInjects
elem_iterator InjectedElements
Cached:
(
Self .Injected
.filter> .IsInjects
.map> .Parent
array:Copy
)
>>> Result
; // InjectedElements
BOOLEAN elem_func IsUses
Self .IsStereotype st_uses::Dependency
>>> Result
; // IsUses
elem_iterator UsesInDependencies
Cached:
(
Self .Dependencies
.filter> .IsUses
.mapToTarget>
array:Copy
)
>>> Result
; // UsesInDependencies
BOOLEAN elem_func IsFactoryInTie
( Self .IsFactory )
AND ( Self .InTie )
>>> Result
; // IsFactoryInTie
INTERFACE elem_func InstanceFreeMethod
Cached:
(
VAR l_TypeName
Self .TypeName >>> l_TypeName
l_TypeName 'Free' Cat MakeProcedure: (
IN aMade
aMade -> %SUM := ( 'Метод освобождения экземпляра синглетона ' l_TypeName Cat )
aMade -> Visibility := PrivateAccess
aMade -> "ifdef" := ( Self .IfDefStr )
aMade -> "ifndef" := ( Self .IfNDefStr )
aMade ->^ cVarUserCodeName ^:= cEmptyUserCode
aMade ->^ cImplementationUserCodeName ^:= [
if ( Self .HasFactory ) then
begin
' IUnknown(' 'g_' l_TypeName ') := nil;'
end
else
begin
' l3Free(' 'g_' l_TypeName ');'
end // ( Self .HasFactory )
]
)
)
>>> Result
; // InstanceFreeMethod
elem_iterator GlobalOperationsPrim
Cached:
(
RULES
( Self .IsInterface )
(
Self .OperationsEx
.filter> .IsStaticMethod
.filter> ( .IsFactoryInTie ! )
)
( Self .IsRecord )
(
Self .OperationsEx
.filter> .IsConstructor
)
( Self .IsUtilityPack )
( Self .OperationsEx )
( Self .IsClassOrMixIn )
(
if ( Self .IsSingleton ) then
begin
[ Self .InstanceFreeMethod ]
end // ( Self .IsSingleton )
else
[empty]
)
DEFAULT
[empty]
; // RULES
VAR l_Operations
array:Copy >>> l_Operations
l_Operations
.joinWithLambded> (
Self .OperationsEx
.filter> .IsIterator
.filter> ( .IsServiceIterator ! )
.filter> ( .IsOverride ! )
.filter> ( l_Operations SWAP .IteratorStub .Name .HasModelElementWithName ! )
) ( .ToArray: .IteratorStub )
)
>>> Result
; // GlobalOperationsPrim
elem_iterator GlobalOperations
Self .GlobalOperationsPrim
.filter> ( .IsIni ! )
.filter> ( .IsFini ! )
.filter> ( .IsKeyWord ! )
.filter> ( .IsGlobalKeyWord ! )
>>> Result
; // GlobalOperations
elem_iterator OperationsUsed
[empty]
.joinWithLambded> ( Self .OperationsEx ) .UsesInDependencies
.joinWithLambded> (
Self .GlobalOperations
.filter> .IsStaticOp
.filter> ( .UPisTrue 'extprop:isAsm' )
) ( DROP ToArray: GarantModel::l3LocalStub )
.joinWithLambded> ( Self .OperationsEx ) call.me
>>> Result
; // OperationsUsed
elem_iterator MixInValues
Self .Attributes
.filter> ( .IsStereotype st_impurity_value::Attribute )
>>> Result
; // MixInValues
BOOLEAN elem_func InheritsOrImplementsMixIn
Cached:
(
RULES
( Self .InheritsEx .filter> .IsMixIn .NotEmpty )
true
( Self .ImplementsEx .filter> .IsMixIn .NotEmpty )
true
DEFAULT
false
; // RULES
)
>>> Result
; // InheritsOrImplementsMixIn
BOOLEAN elem_func ImplementsMixIn
Cached:
(
RULES
//( Self .InheritsEx .filter> .IsMixIn .NotEmpty )
// true
( Self .ImplementsEx .filter> .IsMixIn .NotEmpty )
true
DEFAULT
false
; // RULES
)
>>> Result
; // ImplementsMixIn
elem_iterator OtherMixinValuesUses
[empty]
.joinWithLambded> ( Self .InheritsEx ) ( .MixInValues .mapToTarget> )
.joinWithLambded> ( Self .InheritsEx ) call.me
>>> Result
; // OtherMixinValuesUses
BOOLEAN elem_func IsClass
Self .IsSimpleClass >>> Result
; // IsClass
BOOLEAN elem_func NeedRegisterInScriptsPrim
Cached:
(
RULES
( Self .GetUP "register in scripts" false ?== )
false
( Self .UPisTrue "register in scripts" )
true
( Self .InheritsEx .filter> call.me .NotEmpty )
true
( Self .IsGuiControl )
true
DEFAULT
false
; // RULES
)
>>> Result
; // NeedRegisterInScriptsPrim
BOOLEAN elem_func NeedRegisterInScripts
Cached:
(
RULES
( Self .IsMixIn )
false
( Self .IsVCMCustomForm )
true
( Self .NeedRegisterInScriptsPrim )
RULES
( Self .Name 'Hack' string:Pos -1 != )
false
( Self .IsMixIn )
false
( Self .Abstraction at_abstract == )
true
( Self .IsScriptKeyword )
false
( Self .IsTestClass )
false
( Self .IsClass )
true
( Self .IsEnum )
true
( Self .IsException )
true
( Self .IsInterface )
true
DEFAULT
false
; // RULES
DEFAULT
false
; // RULES
)
>>> Result
; // NeedRegisterInScripts
elem_iterator ImplementsIsInterface
Cached:
(
Self .ImplementsEx .filter> .IsInterface
)
>>> Result
; // ImplementsIsInterface
elem_iterator Used
Cached:
(
Self .UsesInDependencies
if ( Self .IsInterface ! ) then
begin
.join> ( Self .InjectedElements )
.joinWithLambded> ( Self .ImplementsIsInterface ) .InjectedElements
end // Self .IsInterface !
.joinWithLambded> ( Self .InheritsEx .filter> .IsMixIn ) call.me
.joinWithLambded> ( Self .ImplementsEx .filter> .IsMixIn ) call.me
.join> ( Self .OperationsUsed )
if ( Self .InheritsOrImplementsMixIn ) then
begin
.join> ( Self .OtherMixinValuesUses )
end // ( Self .InheritsOrImplementsMixIn )
if ( Self .IsSingleton ) then
begin
.join> ToArray: GarantModel::SysUtils
.join> ToArray: GarantModel::l3Base
end // ( Self .IsSingleton )
if ( Self .IsClassOrMixIn ) then
begin
if ( Self .ImplementedAndOverridden
.filter> .IsIterator
.NotEmpty ) then
begin
.join> ToArray: GarantModel::l3Base
end // ( Self .ImplementedAndOverridden .filter> .IsIterator .NotEmpty )
.joinWithLambded> ( Self .ImplementedAndOverridden ) .UsesInDependencies
end // ( Self .IsClassOrMixIn )
if ( Self .NeedRegisterInScripts ) then
begin
RULES
( Self .IsEnum )
begin
.join> ToArray: GarantModel::TtfwTypeRegistrator(Proxy)
end // ( Self .IsEnum )
( Self .IsException )
begin
.join> ToArray: GarantModel::TtfwTypeRegistrator(Proxy)
end // ( Self .IsException )
( Self .IsInterface )
begin
.join> ToArray: GarantModel::TtfwTypeRegistrator(Proxy)
end // ( Self .IsInterface )
( Self GarantModel::TtfwWord .InheritsFrom ! )
begin
.join> ToArray: GarantModel::TtfwClassRef(Proxy)
end // ( Self GarantModel::TtfwWord .InheritsFrom ! )
; // RULES
end // ( Self .NeedRegisterInScripts )
if ( Self .IsTestCase ) then
begin
.join> ToArray: GarantModel::TestFrameWork
end // ( Self .IsTestCase )
if ( Self .IsScriptKeywordsPack ) then
begin
if (
Self .InheritsEx
.filter> .IsVCMForm
.filter> ( .Abstraction at_final == )
.NotEmpty
) then
begin
Self .InheritsEx
.filter> .IsVCMForm
.filter> ( .Abstraction at_final == )
.for> (
IN aForm
.join> (
aForm .CollectControls
.map> .MainAncestor
.filterNil>
) // .join>
) // .for>
.join> ToArray: GarantModel::TtfwClassRef(Proxy)
end // .filter> .IsVCMForm
end // ( Self .IsScriptKeywordsPack )
)
>>> Result
; // Used
elem_iterator UsedTotal
Self .Used
.joinWithLambded> ( Self .AllOwnChildren ) call.me
>>> Result
; // UsedTotal
elem_iterator AbstractUses
Cached:
(
[empty]
(
Self .InheritsEx
.filter> .IsSimpleClass
.filter> ( .Abstraction at_abstract == )
) .for> (
IN aG
.joinWithLambded> (
aG .ImplementsEx
.filter> .IsMixIn
) // .joinWithLambded>
.UsesInDependencies
.join> ( aG call.me )
) // .for>
)
>>> Result
; // AbstractUses
BOOLEAN elem_func IsTestForTestLibrary
RULES
( Self .IsTestClass )
true
( Self .IsTestCaseMixIn )
true
( Self .IsTestCase )
RULES
( Self .Abstraction at_abstract == )
false
DEFAULT
true
; // RULES
DEFAULT
false
; // RULES
>>> Result
; // IsTestForTestLibrary
elem_iterator DependsVCMGUI
Cached:
(
Self .DependsEx
.filter> .IsVCMGUI
array:Copy
)
>>> Result
; // DependsVCMGUI
elem_iterator DependsTestLibrary
Cached:
(
Self .DependsEx
.filter> .IsTestLibrary
array:Copy
)
>>> Result
; // DependsTestLibrary
elem_iterator ImplUses
Cached:
(
GarantModel::l3ImplUses .ToArray
if ( Self .IsScriptKeywordsPack ) then
begin
.join> ( Self .NeededElementsFromInheritsOrImplements )
end // ( Self .IsScriptKeywordsPack )
.join> ( Self .NeededElements: .IsForImplementation )
.join> ( Self .NeededElementsTotal: .IsForImplementation )
.join> ( Self .UsedTotal )
if ( Self .IsScriptKeywordsPack ) then
begin
.join> ( Self .ChildrenWithOwnFile )
.join> ToArray: GarantModel::SysUtils
.join> ToArray: GarantModel::TtfwTypeRegistrator(Proxy)
.join> ToArray: GarantModel::TypeInfoExt
end // ( Self .IsScriptKeywordsPack )
if ( Self .IsTarget ) then
begin
.join> ( Self .ChildrenWithOwnFile )
end // ( Self .IsTarget )
if ( Self .IsVCMCustomForm ) then
begin
.join> ( Self .ChildrenWithOwnFile )
end // ( Self .IsVCMCustomForm )
if ( Self .IsVCMFormsPack ) then
begin
.join> ( Self .ChildrenWithOwnFile )
end // ( Self .IsVCMFormsPack )
if ( Self .IsVCMFormSetFactory ) then
begin
.join> ( Self .ChildrenWithOwnFile )
end // ( Self .IsVCMFormSetFactory )
if ( Self .IsVCMApplication ) then
begin
.join> ( Self .ChildrenWithOwnFile )
.join> ToArray: GarantModel::evExtFormat
if ( Self .Abstraction at_final == ) then
begin
.join> ToArray: GarantModel::StdRes
end // ( Self .Abstraction at_final == )
end // ( Self .IsVCMApplication )
if ( Self .IsVCMUseCaseRealization ) then
begin
.join> ( Self .ChildrenWithOwnFile )
end // ( Self .IsVCMUseCaseRealization )
if ( Self .IsTestLibrary ) then
begin
.join> ( Self .ChildrenWithOwnFile .filter> .IsTestUnit )
end // ( Self .IsTestLibrary )
if ( Self .IsTestUnit ) then
begin
.join> ( Self .ChildrenWithOwnFile .filter> .IsTestForTestLibrary )
end // ( Self .IsTestUnit )
if ( Self .IsClassOrMixIn ) then
begin
.join> ( Self .AbstractUses )
end // ( Self .IsClassOrMixIn )
if ( Self .IsTestClass ) then
begin
.join> ToArray: GarantModel::Variants
.join> ToArray: GarantModel::ActiveX
.join> ToArray: GarantModel::tc5OpenAppClasses
.join> ToArray: GarantModel::tc5PublicInfo
.join> ToArray: GarantModel::tc6OpenAppClasses
.join> ToArray: GarantModel::tc6PublicInfo
end // ( Self .IsTestClass )
if ( Self .Name 'l3IID' == ) then
begin
.join> ToArray: GarantModel::Windows
.join> ToArray: GarantModel::SysUtils
end // ( Self .Name 'l3IID' == )
RULES
( Self .IsTestTarget )
begin
.join> ToArray: GarantModel::SysUtils
.join> ToArray: GarantModel::l3Base
.join> ToArray: GarantModel::TKBridge
.join> ToArray: GarantModel::KTestRunner
.join> ToArray: GarantModel::TextTestRunner
.join> ToArray: GarantModel::GUITestRunner
if ( Self .UPisTrue "no scripts" ! ) then
begin
.join> ToArray: GarantModel::TvcmInsiderTest
end // ( Self .UPisTrue "no scripts" ! )
end // ( Self .IsTestTarget )
; // RULES
RULES
( Self .IsVCMTestTarget )
begin
RULES
(
Self .DependsVCMGUI
.filter> ( .GetUP "F1Like" false ?== )
.IsEmpty
)
( .join> ToArray: GarantModel::TF1AutoTestSuite )
DEFAULT
( .join> ToArray: GarantModel::TAutoTestsSuite )
; // RULES
.join> ToArray: GarantModel::StdRes
end // ( Self .IsVCMTestTarget )
( Self .IsTestTarget )
begin
if ( Self .UPisTrue "is insider test" ! ) then
begin
if ( Self .UPisTrue "no scripts" ! ) then
begin
.join> ToArray: GarantModel::TAutoTestsSuite
.join> ToArray: GarantModel::TtfwScriptEngineEX
end // ( Self .UPisTrue "no scripts" ! )
end // ( Self .UPisTrue "is insider test" ! )
end // ( Self .IsTestTarget )
( Self .IsVCMGUI )
( .join> ToArray: GarantModel::StdRes )
; // RULES
RULES
( Self .IsTestLibrary )
begin
.join> ( Self .DependsTestLibrary )
RULES
(
Self .ChildrenEx
.filter> .IsTestUnit
.filter> (
.ChildrenEx
.filter> .IsTestClass
.NotEmpty
) // .filter>
.NotEmpty
)
begin
.join> ToArray: GarantModel::tc5OpenApp
.join> ToArray: GarantModel::tc6OpenApp
end
; // RULES
end // ( Self .IsTestLibrary )
( Self .IsTestTarget )
begin
VAR l_Parent
Self .Parent >>> l_Parent
// Сначала перебираем чужие тестовые библиотеки:
.join> (
Self .DependsTestLibrary
.filter> ( .Parent l_Parent .IsSameModelElement ! )
array:Copy
) // .join>
// Потом перебираем свои тестовые библиотеки:
.join> (
Self .DependsTestLibrary
.filter> ( .Parent l_Parent .IsSameModelElement )
array:Copy
) // .join>
end // ( Self .IsTestTarget )
( Self .IsDLL )
begin
VAR l_Parent
Self .Parent >>> l_Parent
Self .DependsEx
.filter> .IsLibrary
.filter> ( .Parent l_Parent .IsSameModelElement )
.for> (
IN aLibrary
aLibrary .ChildrenEx
.for> (
IN aChild
.join> ToArray: aChild
) // .for>
aLibrary .ChildrenEx
.filter> .IsUnit
.for> (
IN aUnit
aUnit .ChildrenEx
.for> (
IN aClass
.join> ToArray: aClass
) // .for>
) // .for>
) // .for>
end // ( Self .IsDLL )
( Self .IsVCMGUI )
begin
.join> ( Self .DependsTestLibrary )
Self .DependsEx
.filter> .IsVCMUseCase
.for> (
IN aUseCase
aUseCase .ChildrenEx
.filter> .IsVCMUseCaseRealization
.for> (
IN aUseCaseRealization
.join> ToArray: aUseCaseRealization
) // .for>
) // .for>
end // ( Self .IsVCMGUI )
; // RULES
)
>>> Result
; // ImplUses
elem_iterator IntfAndImplUses
Self .IntfUses
.join> ( Self .ImplUses )
>>> Result
; // IntfAndImplUses
elem_iterator ProjectUsesPrim
Cached:
(
GarantModel::l3IntfUses .ToArray
RULES
( Self .IsVCMGUI )
begin
if ( Self .GetUP "F1Like" false ?!= ) then
begin
.join> ToArray: GarantModel::nsApplication
end // ( Self .GetUP "F1Like" false ?!= )
.join> ToArray: GarantModel::Tl3ExceptionsLog
.join> ToArray: GarantModel::ControlResizeBugFix
end // ( Self .IsVCMGUI )
( Self .IsVCMTestTarget )
begin
.joinWithLambded> ( Self .DependsVCMGUI ) call.me
end // ( Self .IsVCMTestTarget )
( Self .IsExe )
begin
.join> ToArray: GarantModel::Tl3ExceptionsLog
if ( Self .UPisTrue "console" ! ) then
begin
.join> ToArray: GarantModel::ControlResizeBugFix
end // ( Self .UPisTrue "console" ! )
end // ( Self .IsExe )
; // RULES
.join> ( Self .IntfAndImplUses )
RULES
( Self .IsVCMGUI )
begin
.join> ToArray: GarantModel::Tl3MouseWheelHelper
end // ( Self .IsVCMGUI )
; // RULES
ARRAY VAR l_Uses
[] >>> l_Uses
.mapToUnitProducer>
//.filter> ( Self ?!= )
.filter> ( .NotInArray: l_Uses )
// - возможно это стоит включить, а также включить сюда фильтрацию дубликатов
// чтобы уменьшить повторно выполняемую работу в ProjectUses AccumulateUses
.for> (
.AddToArray: l_Uses
) // .for>
l_Uses
)
>>> Result
; // ProjectUsesPrim
elem_iterator ProjectUses
ARRAY VAR l_ProjectUses
[] >>> l_ProjectUses
ARRAY VAR l_InUses
[] >>> l_InUses
PROCEDURE AccumulateUses
ARRAY IN aUses
aUses
.for> (
IN anItem
//if ( l_InUses .filter> ( anItem ?== ) .IsEmpty ) then
if ( anItem .NotInArray: l_InUses ) then
// - это можно в filter перенести, выше
begin
anItem .AddToArray: l_InUses
anItem .AddToArray: l_ProjectUses
RULES
( anItem IsString )
()
DEFAULT
( anItem .ProjectUsesPrim call.me )
; // RULES
end // ( anItem .NotInArray: l_InUses )
) // .for>
; // AccumulateUses
Self .ProjectUsesPrim AccumulateUses
l_ProjectUses
>>> Result
; // ProjectUses
ModelElement elem_func SecondAttribute
Cached:
(
Self .Attributes .SecondElement
)
>>> Result
; // SecondAttribute
STRING elem_func FineDocumentation
Self .Documentation >>> Result
if ( Result .IsNotNil ) then
begin
Result cOpenComment '[' string:Replace >>> Result
Result cCloseComment ']' string:Replace >>> Result
[ cOpenComment '* ' Result cSpace cCloseComment ] strings:Cat >>> Result
end // Result .IsNotNil
; // FineDocumentation
elem_proc OutDocumentation
STRING VAR l_Doc
Self .FineDocumentation >>> l_Doc
if ( l_Doc .IsNotNil ) then
begin
Indented: ( l_Doc .Out )
end // l_Doc .IsNotNil
; // OutDocumentation
STRING elem_func MethodCallingConventions
RULES
( Self .InTie )
'stdcall'
( Self .IsMethod )
( Self .FirstOperation .GetUP "calling conventions" )
( Self .IsFunction )
( Self .FirstOperation .GetUP "calling conventions" )
DEFAULT
( Self .GetUP "calling conventions" )
; // RULES
>>> Result
if ( Result 'none' == ) then
begin
cEmptyStr >>> Result
end // ( Result 'none' == )
if ( Result .IsNotNil ) then
begin
cSpace Result ';' Cat Cat >>> Result
end // ( Result .IsNotNil )
; // MethodCallingConventions
CONST cConstPrefix 'const '
STRING elem_func InPrefix
Cached:
(
RULES
( Self .IsNil )
cConstPrefix
( Self .IsRecord )
cConstPrefix
( Self .IsUnion )
cConstPrefix
( Self .IsArray )
cConstPrefix
( Self .IsInterface )
cConstPrefix
( Self .IsTypedef )
RULES
( Self .IsPointer )
cEmptyStr
DEFAULT
( Self .MainAncestor call.me )
; // RULES
( Self .IsMixInParamType )
cConstPrefix
( Self .IsString )
cConstPrefix
( Self .IsUntyped )
cConstPrefix
DEFAULT
cEmptyStr
; // RULES
)
>>> Result
; // InPrefix
STRING elem_func ParamPrefix
RULES
( Self .IsStereotype st_in )
( Self .Target .InPrefix )
( Self .IsStereotype st_const )
cConstPrefix
( Self .IsStereotype st_noconst )
cEmptyStr
( Self .IsOutParam )
'out '
( Self .IsStereotype st_inout )
'var '
DEFAULT
( Self .Target .InPrefix )
; // RULES
>>> Result
; // ParamPrefix
BOOLEAN elem_func IsDestructor
RULES
( Self .MethodName 'Destroy' == )
true
( Self .MethodName 'destroy' == )
true
DEFAULT
false
; // RULES
>>> Result
; // IsDestructor
OUTABLE elem_func MethodKeyword
Cached:
(
RULES
( Self .IsStaticConstructor )
'function'
( Self .IsConstructor )
( 'constructor' )
( Self .IsFactory )
( 'class function' )
( Self .IsDestructor )
( 'destructor' )
DEFAULT
(
ModelElement VAR l_Type
Self .MethodType >>> l_Type
VAR l_IsFunc
( l_Type .IsNotNil ) AND ( l_Type .TypeName .IsNotNil ) >>> l_IsFunc
[
RULES
( Self .ParentIsInterface )
()
( Self .UPisTrue 'extprop:isGlobal' )
()
( Self .IsStaticMethod )
'class '
; // RULES
if l_IsFunc then
begin
'function'
end // l_IsFunc
else
begin
'procedure'
end // l_IsFunc
]
) // DEFAULT
; // RULES
)
>>> Result
; // MethodKeyword
BOOLEAN elem_func IsInline
Self .IsStereotype st_inline::Operation
>>> Result
; // IsInline
BOOLEAN elem_func IsOperationOverride
Self .IsStereotype st_override::Operation
>>> Result
; // IsOperationOverride
INTEGER elem_func MethodAbstraction
Cached:
(
Self .OpKind CASE
opkind_Normal
(
RULES
( Self .IsMessageOperation )
at_message
(
( Self .IsIterator )
AND ( Self .MainAncestor .IsNotNil )
)
at_override
( Self .IsStaticConstructor )
at_final
( Self .Parent .IsUtilityPack )
at_final
( Self .Parent .IsStaticObject )
at_final
( Self .ParentIsInterface )
at_final
( Self .IsFunction )
at_final
( Self .IsOperationOverride )
at_override
DEFAULT
( Self .Abstraction )
; // RULES
) // opkind_Normal
opkind_Implemented
(
RULES
( Self .IsVCMOperationPrim )
at_final
( Self .Parent .IsContract )
at_abstract
( Self .ParentIsInterface )
RULES
( Self .IsIteratorF )
at_final
( Self .IsIterator )
RULES
( 'F' Self .Name EndsStr )
at_final
DEFAULT
at_virtual
; // RULES
DEFAULT
at_final
; // RULES
( Self .IsInline )
at_final
DEFAULT
at_override
; // RULES
) // opkind_Implemented
opkind_Overridden
RULES
( Self .IsInline )
at_final
DEFAULT
at_override
; // RULES
DEFAULT
at_final
END // CASE
)
>>> Result
; // MethodAbstraction
STRING elem_func MethodNamePrefix
RULES
( Self .IsSetter )
begin
RULES
( Self .InTie )
'Set'
( Self .UPisTrue "pm" )
'pm_Set'
DEFAULT
'Set_'
; // RULES
end // ( Self .IsSetter )
( Self .IsProperty )
begin
RULES
( Self .InTie )
'Get'
( Self .UPisTrue "pm" )
'pm_Get'
DEFAULT
'Get_'
; // RULES
end // ( Self .IsProperty )
DEFAULT
cEmptyStr
; // RULES
>>> Result
; // MethodNamePrefix
STRING CompileTime-VAR g_MethodParentPrefix ''
BOOLEAN CompileTime-VAR g_EnableMethodDirectives true
BOOLEAN CompileTime-VAR g_EnableMethodDocumentation true
ANY elem_func ExtValue
Cached:
(
Self .GetUP 'extprop:pas:Value' >>> Result
if ( Result .IsValueValid ) then
begin
RULES
( Result IsString )
begin
RULES
( '.[]' Result EndsStr )
begin
'[]' >>> Result
end // ( '.[]' Result EndsStr )
( '.nil' Result EndsStr )
begin
'nil' >>> Result
end // ( '.[]' Result EndsStr )
(
( ']' Result EndsStr )
AND ( '[' Result StartsStr ! )
)
begin
VAR l_Head
Result cDot string:Split >>> Result >>> l_Head
if ( Result .IsNil ) then
begin
l_Head >>> Result
end // ( Result .IsNil )
end // ( '.[]' Result EndsStr )
( 'vcmUserControls.vcm_utAny' Result == )
( 'vcm_utAny' >>> Result )
( 'evdInterfaces.evDefaultStoreFlags' Result == )
( 'evDefaultStoreFlags' >>> Result )
DEFAULT
begin
VAR l_Type
Self .ValueType >>> l_Type
if ( l_Type .IsNotNil ) then
begin
VAR l_Target
Self .Target >>> l_Target
if (
( l_Target .IsNil )
OR ( l_Target l_Type != )
) then
begin
VAR l_Unit
l_Type .EffectiveUnitName >>> l_Unit
if ( Self .EffectiveUnitName l_Unit != ) then
begin
l_Unit cDot Cat >>> l_Unit
if ( l_Unit Result StartsStr ! ) then
begin
l_Unit Result Cat >>> Result
end // ( l_Unit Result StartsStr ! )
end // ( Self .EffectiveUnitName l_Unit != )
end // ( Self .Target l_Type != )
end // ( l_Type .IsNotNil )
end // DEFAULT
; // RULES
end // ( Result IsString )
; // RULES
end // ( Result .IsValueValid )
Result
)
>>> Result
; // ExtValue
elem_proc MethodInterfacePrim
IN aPrefix
IN aOverload
IN aOfObject
IN aBody
: OutOverload
aOverload DO
; // OutOverload
: OutCallingConventions
Self .MethodCallingConventions
; // OutCallingConventions
: OutReintroduce
RULES
( Self .IsStaticConstructor )
()
( Self .ParentIsInterface )
()
( Self .IsConstructor )
( ' reintroduce;' )
( Self .IsFactory )
( ' reintroduce;' )
; // RULES
; // OutReintroduce
RULES
( Self .IsNil )
()
DEFAULT
begin
Self .IfDef:
(
[
aPrefix DO
ModelElement VAR l_Type
Self .MethodType >>> l_Type
VAR l_IsFunc
RULES
( Self .IsSetter )
(
false >>> l_IsFunc
'procedure'
)
DEFAULT
(
( l_Type .IsNotNil ) AND ( l_Type .TypeName .IsNotNil ) >>> l_IsFunc
Self .MethodKeyword
)
; // RULES
if ( Self .IsFunction ! ) then
begin
cSpace
g_MethodParentPrefix
RULES
( Self .IsProperty )
(
Self .MethodNamePrefix
Self .MethodName
)
DEFAULT
( Self .MethodName )
; // RULES
end // ( Self .IsFunction ! )
VAR l_WasParam
false >>> l_WasParam
VAR l_MethodAbstraction
Self .MethodAbstraction >>> l_MethodAbstraction
RULES
( Self .IsSetter )
(
Self .PropertyKeys
.join> ToArray: ( l_Type .ValueParam )
)
( Self .IsProperty )
( Self .PropertyKeys )
DEFAULT
( Self .MethodParameters )
; // RULES
.for> (
IN aParam
if ( l_WasParam ! ) then
'('
VAR l_WasIf
false >>> l_WasIf
elem: IfDefBraceLn:
^ IN aLambda
Self nil .IfDefPrim: (
\n
l_WasIf ! ? SWAP
true >>> l_WasIf
)
(
aLambda DO
l_WasIf ? \n
) // Self .IfDefPrim:
; // IfDefBraceLn:
aParam .IfDefBraceLn:
(
if ( l_WasParam ) then
begin
';' \n cSpace
end
true >>> l_WasParam
aParam .ParamPrefix
aParam .Name
VAR l_Type
aParam .Target >>> l_Type
if ( l_Type .IsNotNil ) then
begin
': ' l_Type .TypeName
end // ( l_Type .IsNotNil )
//if ( l_MethodAbstraction at_override != ) then
begin
VAR l_Value
aParam .ExtValue >>> l_Value
//aParam .GetUP 'Value' >>> l_Value
if ( l_Value .IsValueValid ) then
begin
' = ' l_Value
end // ( l_Value .IsValueValid )
end // ( l_MethodAbstraction at_override != )
VAR l_Doc
aParam .FineDocumentation >>> l_Doc
if ( l_Doc .IsNotNil ) then
begin
\n cSpace l_Doc
end // ( l_Doc .IsNotNil )
) // aParam .IfDefBraceLn:
) // Self .MethodParameters .for>
if ( l_WasParam ) then
')'
if l_IsFunc then
begin
': ' l_Type .TypeName
end // l_IsFunc
aOfObject DO
';'
if g_EnableMethodDirectives then
begin
l_MethodAbstraction CASE
at_final (
OutReintroduce
OutOverload
OutCallingConventions
)
at_virtual (
OutReintroduce
OutOverload
' virtual;'
OutCallingConventions
)
at_abstract (
OutReintroduce
OutOverload
' virtual; abstract;'
OutCallingConventions
)
at_override
' override;'
at_message (
' message ' Self .GetUP "Message ID" ';'
)
END // CASE
end // g_EnableMethodDirectives
VAR l_WasComma
false >>> l_WasComma
VAR l_WasOut
false >>> l_WasOut
RULES
( Self .IsSetter )
( Self .CanRaiseInSet )
DEFAULT
( Self .CanRaise )
; // RULES
.for> (
IN anItem
if ( l_WasOut ! ) then
begin
true >>> l_WasOut
cSpace cOpenComment ' can raise '
end // ( l_WasOut ! )
anItem .TypeName .WithComma: l_WasComma .KeepInStack
) // Self .CanRaise .for>
if l_WasOut then
begin
cSpace
cCloseComment
end // l_WasOut
]
.Out? ? (
if g_EnableMethodDocumentation then
if ( Self .IsProperty ! ) then
begin
Self .OutDocumentation
end // ( Self .IsProperty ! )
Self aBody DO
) // .Out? ?
) // Self .IfDef:
end // DEFAULT
; // RULES
; // MethodInterfacePrim
elem: AsSetterDo:
^ IN aLambda
RULES
( Self .IsWriteonlyProperty )
( Self aLambda DO )
DEFAULT
(
Self .DecorateMethodAndDo: (
IN aMethod
aMethod -> OpModify := opModifySetter
aMethod aLambda DO
) // Self .DecorateMethodAndDo:
) // DEFAULT
; // RULES
; // AsSetterDo:
elem: AsTestDo:
^ IN aLambda
Self .DecorateMethodAndDo: (
IN aMethod
aMethod -> OpModify := opModifyTest
aMethod aLambda DO
) // Self .DecorateMethodAndDo:
; // AsTestDo:
elem: AsExecuteDo:
^ IN aLambda
Self .DecorateMethodAndDo: (
IN aMethod
aMethod -> OpModify := opModifyExecute
aMethod aLambda DO
) // Self .DecorateMethodAndDo:
; // AsExecuteDo:
elem: AsGetStateDo:
^ IN aLambda
Self .DecorateMethodAndDo: (
IN aMethod
aMethod -> OpModify := opModifyGetState
aMethod aLambda DO
) // Self .DecorateMethodAndDo:
; // AsGetStateDo:
elem: AsIteratorFDo:
^ IN aLambda
Self .DecorateMethodAndDo: (
IN aMethod
aMethod -> OpModify := opModifyIteratorF
aMethod ->^ cVarUserCodeName ^:= [
'var' \n
' Hack : Pointer absolute anAction;'
]
aMethod ->^ cImplementationUserCodeName ^:= [
' try' \n
' '
if ( Self .UPisTrue "needs result" ) then
'Result := '
RULES
( Self .IsMethodAndImplementsIterator )
( Self .MainImplements .MethodName )
DEFAULT
( Self .Name )
; // RULES
Self .ParametersList
';'
\n
' finally' \n
' l3FreeLocalStub(Hack);' \n
' end;//try..finally'
]
aMethod aLambda DO
) // Self .DecorateMethodAndDo:
; // AsIteratorFDo:
elem_proc MethodInterfaceEx
IN aPrefix
IN aOverload
IN aOfObject
IN aBody
: NormalCall
Self aPrefix aOverload aOfObject aBody .MethodInterfacePrim
; // NormalCall
: CallAsGetter
if ( Self .ReadsField ! ) then
if ( Self .UPisTrue "inherits getter from some ancestor" ! ) then
NormalCall
; // CallAsGetter
: CallAsSetter
if ( Self .WritesField ! ) then
if ( Self .UPisTrue "inherits setter from some ancestor" ! ) then
( Self .AsSetterDo: ( aPrefix aOverload aOfObject aBody .MethodInterfacePrim ) )
; // CallAsSetter
RULES
( Self .IsVCMOperationPrim )
(
//if ( Self .IsInternalOperation ! ) then
begin
if (
( Self .UPisTrue "is query" ! )
AND ( Self .UPisTrue "no test" ! )
) then
begin
Self .AsTestDo: ( aPrefix aOverload aOfObject aBody .MethodInterfacePrim )
end // ( Self .UPisTrue "is query" ! ) ..
end // ( Self .IsInternalOperation ! )
if (
( Self .UPisTrue "is FormActivate" ! )
OR ( Self .IsInternalOperation )
) then
begin
Self .AsExecuteDo: ( aPrefix aOverload aOfObject aBody .MethodInterfacePrim )
end // ( Self .UPisTrue "is FormActivate" ! )
if ( Self .IsInternalOperation ! ) then
begin
if ( Self .UPisTrue "has states" ) then
begin
Self .AsGetStateDo: ( aPrefix aOverload aOfObject aBody .MethodInterfacePrim )
end // ( Self .UPisTrue "has states" )
end // ( Self .IsInternalOperation ! )
if ( Self .IsInternalOperation ) then
NormalCall
) // ( Self .IsVCMOperationPrim )
( Self .IsReadonlyProperty )
CallAsGetter
( Self .IsWriteonlyProperty )
CallAsSetter
( Self .IsProperty )
(
CallAsGetter
CallAsSetter
) // ( Self .IsProperty )
( Self .IsIterator )
(
NormalCall
if ( 'F' Self .Name EndsStr ! )
if ( Self .IsOverride ! ) then
begin
( Self .AsIteratorFDo: ( aPrefix aOverload aOfObject aBody .MethodInterfacePrim ) )
end // ( Self .IsOverride ! )
) // ( Self .IsIterator )
( Self .IsMethodAndImplementsIterator )
(
NormalCall
if ( 'F' Self .Name EndsStr ! )
//if ( Self .IsOverride ! ) then
begin
( Self .AsIteratorFDo: ( aPrefix aOverload aOfObject aBody .MethodInterfacePrim ) )
end // ( Self .IsOverride ! )
) // ( Self .IsIterator )
DEFAULT
NormalCall
; // RULES
; // MethodInterfaceEx
elem_proc MethodInterfaceEx:
^ IN aPrefix
^ IN aOverload
^ IN aOfObject
^ IN aLambda
Self aPrefix aOverload aOfObject aLambda .MethodInterfaceEx
; // MethodInterfaceEx:
BOOLEAN elem_func CanBeClassAncestor
RULES
( Self .IsClassOrMixIn )
true
( Self .IsException )
true
( Self .IsEvdSchemaElement )
true
( Self .IsTypedef )
RULES
( Self .IsPointer )
false
DEFAULT
( Self .MainAncestor call.me )
; // RULES
DEFAULT
false
; // RULES
>>> Result
; // CanBeClassAncestor
ModelElement elem_func MainClassAncestor
Cached:
(
Self .InheritsEx
.filter> .CanBeClassAncestor
.FirstElement
)
>>> Result
; // MainClassAncestor
elem_iterator MixInPropertiesTotal
Cached:
(
Self .Properties
.joinWithLambded> ( Self .ImplementsEx .filter> .IsPureMixIn ) call.me
.joinWithLambded> ( Self .InheritsEx .filter> .IsPureMixIn ) call.me
)
>>> Result
; // PropertiesTotal
elem_iterator InterfacePropertiesTotal
Cached:
(
Self .Properties
.joinWithLambded> ( Self .ImplementsEx .filter> .IsPureMixIn ) .MixInPropertiesTotal
)
>>> Result
; // InterfacePropertiesTotal
elem_iterator InterfaceProperties
Cached:
(
RULES
( Self .IsPureMixIn )
( Self .Properties )
DEFAULT
( Self .InterfacePropertiesTotal )
; // RULES
)
>>> Result
; // InterfaceProperties
INTERFACE elem_func InstanceMethod
Cached:
(
VAR l_TypeName
Self .TypeName >>> l_TypeName
'Instance' Self MakeFunction: (
IN aMade
aMade -> Stereotype := st_static::Operation
aMade -> %SUM := ( 'Метод получения экземпляра синглетона ' l_TypeName Cat )
aMade -> Visibility := PublicAccess
aMade ->^ cVarUserCodeName ^:= cEmptyUserCode
aMade ->^ cImplementationUserCodeName ^:= [
' if (' 'g_' l_TypeName ' = nil) then' \n
' begin' \n
' l3System.AddExitProc(' l_TypeName 'Free' ');' \n
' g_' l_TypeName ' := Create;' \n
' end;' \n
' Result := g_' l_TypeName ';'
]
)
)
>>> Result
; // InstanceMethod
INTERFACE elem_func ExistsMethod
Cached:
(
VAR l_TypeName
Self .TypeName >>> l_TypeName
'Exists' GarantModel::Boolean MakeFunction: (
IN aMade
aMade -> Stereotype := st_static::Operation
aMade -> %SUM := 'Проверяет создан экземпляр синглетона или нет'
aMade -> Visibility := PublicAccess
aMade ->^ cVarUserCodeName ^:= cEmptyUserCode
aMade ->^ cImplementationUserCodeName ^:= [
' Result := g_' l_TypeName ' <> nil;'
]
)
)
>>> Result
; // ExistsMethod
INTERFACE elem_func FakeMethod
Cached:
(
'Fake' MakeProcedure: (
IN aMade
aMade -> %SUM := 'это нужно чтобы правильно генерировались вызовы методов доступа к свойствам'
aMade -> Visibility := PrivateAccess
aMade -> Abstraction := at_virtual
aMade ->^ cVarUserCodeName ^:= cEmptyUserCode
aMade ->^ cImplementationUserCodeName ^:= ' Assert(false);'
)
)
>>> Result
; // FakeMethod
INTERFACE elem_func InitConstructor
Cached:
(
'Init' MakeProcedure: (
IN aMade
aMade -> Stereotype := st_ctor::Operation
aMade -> Visibility := PublicAccess
aMade -> Abstraction := at_final
aMade -> UID := ( Self .LUID 'Init' Cat )
if ( Self .IsAutoHelper ) then
begin
aMade -> Parameters := [
Self .ImplementsEx .for> (
IN aR
'a' aR .TypeName Cat aR MakeParam
)
]
aMade ->^ cImplementationUserCodeName ^:= [
Self .ImplementsEx .for> (
IN aR
' ' 'f_' aR .TypeName ' := ' 'a' aR .TypeName ';'
)
]
end // ( Self .IsAutoHelper )
aMade ->^ cVarUserCodeName ^:= cEmptyUserCode
//aMade ->^ cImplementationUserCodeName ^:= ' Assert(false);'
)
)
>>> Result
; // InitConstructor
BOOLEAN elem_func NeedsFakeMethod
Cached:
(
RULES
( Self .IsAutoHelper )
true
( Self .Properties .filter> ( .ReadsField ! ) .NotEmpty )
true
DEFAULT
false
; // RULES
)
>>> Result
; // NeedsFakeMethod
BOOLEAN elem_func IsSettingsHolder
Self .IsStereotype st_SettingsHolder
>>> Result
; // IsSettingsHolder
BOOLEAN elem_func IsInterfaceFactory
Self .IsStereotype st_InterfaceFactory
>>> Result
; // IsInterfaceFactory
BOOLEAN elem_func UseNewGen
Cached:
(
RULES
( Self .IsNil )
false
( Self .IsUserType )
true
( Self .IsElementProxy )
true
( Self .IsTestClass )
true
( Self .IsTestCase )
true
( Self .IsScriptKeyword )
RULES
( Self .Parent .IsVCMControls )
false
( Self .Parent .IsVCMModule )
true
DEFAULT
true
; // RULES
( Self .IsScriptKeywordsPack )
true
( Self .IsUtilityPack )
true
( Self .IsScriptKeywords )
true
( Self .IsStereotype st_Wrapper )
true
( Self .IsStereotype st_EVD )
false
( Self .UPisTrue "UseNewGen" )
true
( Self .GetUP "finished" false ?== )
true
( Self .ForceUseNewGen )
true
( Self .IsVCMCustomForm )
( Self .Parent call.me )
( Self .IsGuiControl )
true
( Self .IsUseCaseControllerImp )
( Self .Parent call.me )
( Self .IsViewAreaControllerImp )
( Self .Parent call.me )
( Self .IsVCMControls )
( Self .Parent call.me )
( Self .IsMixIn )
true
( Self .IsControllerInterfaces )
true
( Self .IsInternalInterfaces )
true
( Self .IsInterfaces )
true
( Self .IsService )
true
( Self .IsServiceImplementation )
true
( Self .IsSettingsHolder )
( Self .Parent call.me )
( Self .IsInterfaceFactory )
( Self .Parent call.me )
( Self .IsVCMFormSetFactory )
( Self .Parent call.me )
( Self .IsVCMFormsPack )
( Self .Parent call.me )
( Self .IsVCMApplication )
true
( Self .IsTestResults )
true
( Self .IsSimpleClass )
true
( Self .IsTestLibrary )
true
( Self .IsLibrary )
( Self .Parent call.me )
( Self .IsVCMTestTarget )
true
( Self .IsTestTarget )
true
( Self .IsVCMGUI )
true
( Self .IsExeTarget )
true
( Self .IsDLL )
true
( Self .IsTarget )
( Self .Parent call.me )
DEFAULT
( Self .Parent call.me )
; // RULES
)
>>> Result
; // UseNewGen
elem_iterator AllOperationsForOverload
Cached:
(
RULES
( Self .IsPureMixIn )
( Self .InterfaceOwnOperations )
( Self .IsInterface )
( Self .InterfaceOperationsTotal )
( Self .IsStaticObject )
(
Self .OperationsEx
.filter> ( .IsStaticConstructor ! )
.join> ( Self .ImplementedEx )
if ( Self .NeedsFakeMethod ) then
begin
.join> ToArray: ( Self .FakeMethod )
.join> ToArray: ( Self .InitConstructor )
end // ( Self .NeedsFakeMethod )
)
( Self .IsClassOrMixIn )
(
Self .OperationsEx
VAR l_CastMethods
[] >>> l_CastMethods
( Self .ClassImplementsPrim ) .for> (
IN anItem
.joinWithLambded>
(
anItem .InterfaceForClassImplements
.filter> ( .NotInArray: l_CastMethods )
)
(
IN anItem
anItem .AddToArray: l_CastMethods
anItem .ToArray: .CastMethod
)
)
.filter> ( .IsStereotype st_responsibility::Operation ! )
.filter> ( .IsServiceIterator ! )
.filter> ( .IsIni ! )
.filter> ( .IsFini ! )
(
VAR l_VCMOperations
[] >>> l_VCMOperations
.join> (
Self .ImplementedEx
.filter> ( .IsInline ! )
.filter> (
IN anOp
if ( anOp .IsVCMOperationPrim ) then
begin
VAR l_Name
anOp .MethodName >>> l_Name
if ( l_Name .StringNotInArray: l_VCMOperations ) then
begin
l_Name .AddToArray: l_VCMOperations
true
end // ( l_Name .StringNotInArray: l_VCMOperations )
else
false
end // .IsVCMOperationPrim
else
true
) // .filter>
array:Copy
) // join> ( Self .ImplementedEx )
)
if ( Self .IsSingleton ) then
begin
if ( Self .HasFactory ! ) then
begin
.join> ToArray: ( Self .InstanceMethod )
end // ( Self .HasFactory ! )
//if ( Self .UseNewGen ) then
begin
if ( Self .OperationsEx 'Exists' .HasModelElementWithName ! ) then
begin
.join> ToArray: ( Self .ExistsMethod )
end // ( Self .OperationsEx 'Exists' .HasModelElementWithName ! )
end // ( Self .UseNewGen )
end // ( Self .IsSingleton )
)
DEFAULT
( Self .OperationsEx )
; // RULES
)
>>> Result
; // AllOperationsForOverload
elem_iterator AllOperationsForDefine
Cached:
(
RULES
( Self .IsPureMixIn )
( Self .Properties )
( Self .IsInterface )
( Self .InterfacePropertiesTotal )
(
( Self .IsStaticObject )
OR ( Self .IsClassOrMixIn )
)
(
Self .Properties
.filter> ( IN anItem
( anItem .ReadsField ! )
OR ( anItem .WritesField ! )
)
)
DEFAULT
[empty]
; // RULES
.join> ( Self .AllOperationsForOverload )
RULES
( Self .IsClassOrMixIn )
(
.join>
(
Self .OverriddenEx
.filter> ( .IsVCMOperationPrim ! )
)
.filter> ( .IsInline ! )
)
; // RULES
)
>>> Result
; // AllOperationsForDefine
elem_proc MethodInterfaceForEx:
^ IN anOperations
^ IN aLambda
Self .MethodInterfaceEx: () (
ARRAY VAR l_Ops
anOperations DO >>> l_Ops
if ( l_Ops .IsNotNil ) then
begin
if ( Self .UPisTrue "force overload" ) then
begin
' overload;'
end // ( Self .UPisTrue "force overload" )
else
begin
if ( l_Ops
.filter> ( .IsProperty ! )
.filter> ( .IsVCMOperationPrim ! )
.filter> ( .MethodName Self .MethodName == )
.CountIt > 1 ) then
begin
' overload;'
end // l_Ops ..
end // ( Self .UPisTrue "force overload" )
end // ( l_Ops .IsNotNil )
) () (
aLambda DO
)
; // MethodInterfaceForEx:
elem_proc MethodInterfaceFor:
^ IN anOperations
Self .MethodInterfaceForEx: ( anOperations DO ) DROP
; // MethodInterfaceFor:
STRING elem_func PropertyName
Cached:
(
RULES
( Self .InTie )
( Self .Name .FromTie )
DEFAULT
( Self .Name )
; // RULES
)
>>> Result
; // PropertyName
elem_proc OutProperty
Self .IfDef:
(
[
'property '
Self .PropertyName
VAR l_WasParam
false >>> l_WasParam
Self .PropertyKeys .for> (
IN aParam
if l_WasParam then
'; '
else
begin
true >>> l_WasParam
'['
end
aParam .ParamPrefix
aParam .Name
': '
aParam .Target .TypeName
)
if l_WasParam then
']'
': '
Self .MethodType .TypeName
: OutRead
\n cSpace 'read' cSpace
if ( Self .ReadsField ) then
'f_'
else
begin
Self .MethodNamePrefix
end // ( Self .ReadsField )
Self .MethodName
; // OutRead
: OutWrite
\n cSpace 'write' cSpace
if ( Self .WritesField ) then
'f_'
else
begin
Self .AsSetterDo: .MethodNamePrefix
end // ( Self .WritesField )
Self .MethodName
; // OutWrite
RULES
( Self .IsReadonlyProperty )
OutRead
( Self .IsWriteonlyProperty )
()
( Self .IsProperty )
OutRead
; // RULES
RULES
( Self .IsReadonlyProperty )
()
( Self .IsWriteonlyProperty )
OutWrite
( Self .IsProperty )
OutWrite
; // RULES
if ( Self .UPisTrue "needs stored directive" ) then
begin
\n
' stored '
Self .MethodName
'Stored'
end // ( Self .UPisTrue "needs stored directive" )
VAR l_Value
Self .ExtValue >>> l_Value
if ( l_Value .IsValueValid ) then
begin
\n
' default ' l_Value
end // ( l_Value .IsValueValid )
';'
if ( Self .UPisTrue "is default" ) then
begin
\n
' default;'
end // ( Self .UPisTrue "is default" )
] .Out? ?
( Self .OutDocumentation )
) // Self .IfDef:
; // OutProperty
PROCEDURE .ByVisibility>
ARRAY IN anArray
^ IN aFilter
^ IN aOut
BOOLEAN VAR l_WasOut
STRING VAR l_Separator
PROCEDURE DoOut
IN anItem
if ( l_WasOut ! ) then
begin
true >>> l_WasOut
l_Separator .Out
end // ( l_WasOut )
Indented: ( anItem aOut DO )
; // DoOut
false >>> l_WasOut
'private' >>> l_Separator
anArray .filter> ( aFilter DO PrivateAccess == ) .for> DoOut
false >>> l_WasOut
'protected' >>> l_Separator
anArray .filter> ( aFilter DO ProtectedAccess == ) .for> DoOut
false >>> l_WasOut
'public' >>> l_Separator
anArray .filter> ( aFilter DO PublicAccess == ) .for> DoOut
'published' >>> l_Separator
anArray .filter> ( aFilter DO PublishedAccess == ) .for> DoOut
; // .ByVisibility>
elem_proc OutField
Self .IfDef:
(
[
Self .FieldName
': '
Self .MethodType .TypeName
';'
] .Out? ? (
Self .OutDocumentation
) // .Out? ?
) // Self .IfDef:
; // OutField
INTEGER elem_func MethodVisibility
Cached:
(
RULES
( Self .IsProperty )
ProtectedAccess
( Self .IsStereotype st_Test )
PublishedAccess
( Self .OpKind opkind_Implemented == )
RULES
( Self .Parent .IsPureMixIn )
PublicAccess
( Self .ParentIsInterface )
ProtectedAccess
( Self .IsStaticMethod )
PublicAccess
(
( Self .Visibility PrivateAccess == )
AND ( Self .Abstraction at_abstract == )
)
ProtectedAccess
DEFAULT
( Self .Visibility )
; // RULES
( Self .OpKind opkind_Overridden == )
RULES
(
Self .IsStaticMethod
AND ( Self .Abstraction at_abstract == )
)
PublicAccess
( Self .Visibility PrivateAccess == )
ProtectedAccess
DEFAULT
( Self .Visibility )
; // RULES
DEFAULT
( Self .Visibility )
; // RULES
)
>>> Result
; // MethodVisibility
elem_iterator ClassProperties
Cached:
(
Self .Properties
.join> (
( Self .ImplementedEx )
.filter> .IsProperty
.filter> ( .Parent .IsContract )
)
)
>>> Result
; // ClassProperties
INTEGER elem_func FieldVisibility
RULES
( Self .IsProperty )
PrivateAccess
DEFAULT
( Self .Visibility )
; // RULES
>>> Result
; // FieldVisibility
elem_proc OutClassInner
Indented: (
Self .Fields .ByVisibility> .FieldVisibility .OutField
TF g_Implementor (
Self >>> g_Implementor
VAR l_AllOps
Self .AllOperationsForOverload >>> l_AllOps
Self .AllOperationsForDefine
.ByVisibility> .MethodVisibility
.MethodInterfaceFor: l_AllOps
Self .ClassProperties .ByVisibility> .Visibility .OutProperty
) // TF g_Implementor
if ( Self .IsStaticObject ) then
begin
VAR l_WasSection
false >>> l_WasSection
( Self .Attributes .filter> ( .Target .IsUnion ) ) .for> (
IN aProp
aProp .Target .Attributes
.filter> ( .IsStereotype st_switch::Attribute ! )
.filter> ( .Name 'void' SWAP StartsStr )
.for> (
IN aField
aField .Target .Attributes .for> (
IN aField
if ( l_WasSection ! ) then
begin
'public' .Out
true >>> l_WasSection
end // ( l_WasSection ! )
Indented:
(
[
'property ' aField .Name ': ' aField .Target .TypeName
\n
cSpace 'read' cSpace aProp .Name cDot aField .Name
\n
cSpace 'write' cSpace aProp .Name cDot aField .Name
';'
] .Out
) // Indented:
)
)
)
end // ( Self .IsStaticObject )
) // Indented:
if ( Self .UPisTrue "need UC" ) then
begin
Self .UserCode: 'publ' ()
end // ( Self .UPisTrue "need UC" )
; // OutClassInner
elem_iterator InheritsNotMixIn
Cached:
(
Self .InheritsEx .filterMixIns>
)
>>> Result
; // InheritsNotMixIn
BOOLEAN elem_func IsInheritsNotMixInCount
Cached:
(
Self .InheritsNotMixIn .NotEmpty
)
>>> Result
; // IsInheritsNotMixInCount
ModelElement elem_func TagClass
%SUMMARY
'Класс, реализующий тег.'
'Возможно будет расширяться, когда будем делать генерацию EVD-схемы.'
'И станет полноценным классом с реализуемыми и перекрытыми методами.'
;
Cached:
(
Self .TypeName 'Class' Cat nil MakeClass
)
>>> Result
; // TagClass
ModelElement elem_func MainAncestorThatNotMixIn
%SUMMARY
'Возвращает имя родительский класс, который не является примесью.'
'Или умолчательного предка'.
;
/*
[{}{\
%S%f_pas_DefaultAncestor()\
}\
<{}{%G#f_IsMixIn()!=true}\
%f_pas_TypeName(%G)[{%GS=Tag}Class]\
>\
]
*/
Cached:
(
RULES
( Self .IsInheritsNotMixInCount ! )
( Self .DefaultAncestor )
( Self .InheritsNotMixIn .filter> .IsTag .IsEmpty )
( Self .InheritsNotMixIn .FirstElement )
DEFAULT
begin
Self .InheritsNotMixIn
.filter> .IsTag
.map> .TagClass
.FirstElement
end // DEFAULT
; // RULES
)
>>> Result
; // MainAncestorThatNotMixIn
ModelElement elem_func MixInParentName
%SUMMARY 'Псевдо класс для указания родительсого типа примеси.' ;
Cached:
(
Self .TypeName 'Parent_' Cat nil MakeClass
)
>>> Result
; // MixInParentName
STRING elem_func PasPathOnly
Cached:
(
Self .GetUP 'intf.pas:PathOnly' >>> Result
if ( Result .IsNil ) then
begin
Self .Parent call.me >>> Result
end // ( Result .IsNil )
else
begin
Result '\MDProcess\components\' '\common\components\' string:ReplaceFirst >>> Result
end // ( Result .IsNil )
Result
)
>>> Result
; // PasPathOnly
STRING elem_func PathOnly
Cached:
(
Self .FinalFileName sysutils:ExtractFilePath >>> Result
if ( Result .IsNil ) then
begin
Self .PasPathOnly >>> Result
if ( Result .IsNotNil ) then
begin
Result '\' .CutPrefix >>> Result
[ cRoot
// - это потому, что в пути нету диска, а для ExtractFileName он нужен
Result ] cPathSep strings:CatSep >>> Result
Result cPathSep Cat >>> Result
end // ( Result .IsNotNil )
end // ( Result .IsNil )
Result
)
>>> Result
; // PathOnly
elem_proc OutMixInInclude
[ cOpenComment '$Include' ' ' Self .PathOnly Self .UnitName '.pas' cCloseComment ] .Out
; // OutMixInInclude
BOOLEAN elem_func HasNonMixInAncestor
Cached:
(
RULES
( Self .IsInheritsNotMixInCount )
true
( Self .InheritsEx .filter> call.me .NotEmpty )
true
DEFAULT
false
; // RULES
)
>>> Result
; // HasNonMixInAncestor
ModelElement elem_func_with_side_effects CalcParentAndInclude
RULES
( Self .IsMixIn )
RULES
( Self .IsInheritsNotMixInCount )
( Self .MainClassAncestor )
DEFAULT
( Self .MixInParentName )
; // RULES
DEFAULT
( Self .MainAncestorThatNotMixIn )
; // RULES
>>> Result
: RefG
IN aG
if ( Result .IsNotNil ) then
begin
[ aG .MixInParentName .TypeName ' = ' Result .TypeName ';' ] .Out
end // ( Result .IsNotNil )
; // RefG
VAR l_WasProlog
false >>> l_WasProlog
: DoG
IN aG
aG >>> Result
//aG .TypeName >>> Result
if ( l_WasProlog ! ) then
begin
true >>> l_WasProlog
if ( aG GarantModel::l3Items .InheritsFrom ) then
begin
: OutIsProto
[ cOpenComment '$Define ' 'l3Items_IsProto' cCloseComment ] .Out
; // OutIsProto
RULES
( Self GarantModel::Tl3ProtoObject .InheritsFrom )
OutIsProto
(
( Self GarantModel::Tl3DataContainerWithoutIUnknownPrim .InheritsFrom )
AND NOT ( Self GarantModel::Tl3DataContainerWithoutIUnknown .InheritsFrom )
)
OutIsProto
; // RULES
end // ( aG GarantModel::l3Items .InheritsFrom )
end // ( l_WasProlog ! )
aG .OutMixInInclude
; // DoG
Self .InheritsEx .filter> .IsMixIn .for> (
IN aG
if ( Result .IsNotNil ) then
begin
if ( aG .HasNonMixInAncestor ! ) then
begin
aG RefG
end // ( aG .HasNonMixInAncestor ! )
end // ( Result .IsNotNil )
aG DoG
)
Self .ImplementsEx .filter> .IsMixIn .for> (
IN aG
aG RefG
aG DoG
)
; // CalcParentAndInclude
elem_proc DefineMixInValues
Self .MixInValues .for> (
IN aValue
g_MixInParamTypes ->^ ( aValue .Name ) ^:= ( aValue .Target )
) // Self .MixInValues .for>
; // DefineMixInValues
elem_proc UndefineMixInValues
Self .MixInValues .for> (
IN aValue
g_MixInParamTypes ->^ ( aValue .Name ) ^:= nil
) // Self .MixInValues .for>
; // UndefineMixInValues
elem_proc DefineImplementedMixInValues
Self .ImplementsIsInterface .for> .DefineMixInValues
; // DefineImplementedMixInValues
elem_proc UndefineImplementedMixInValues
Self .ImplementsIsInterface .for> .UndefineMixInValues
; // DefineImplementedMixInValues
ARRAY CompileTime-VAR g_MixInValues nil
elem_iterator AllInlinedOperations
Cached:
(
Self .ImplementedAndOverridden
.filter> .IsInline
)
>>> Result
; // AllInlinedOperations
elem_proc OutOtherMixinValues
Self .InheritsEx .for> (
IN aG
aG .MixInValues .for> (
IN aValue
if ( aValue .Name .TextNotInArray: g_MixInValues ) then
begin
aValue .Name .AddToArray: g_MixInValues
[
'{$If not Declared(' cUnderline aValue .Name cUnderline ')' '}'
'type' ' '
cUnderline aValue .Name cUnderline ' = ' aValue .Target .TypeName ';'
'{$IfEnd}'
\n
] .Out
end // ( aValue .Name .TextNotInArray: g_MixInValues )
) // aG .MixInValues .for>
aG call.me
) // Self .InheritsEx .for>
; // OutOtherMixinValues
elem_proc OutClass
Self .DefineImplementedMixInValues
if ( Self .UPisTrue "need UC" ) then
begin
Self .UserCode: 'ci' ()
end // ( Self .UPisTrue "need UC" )
Self .MixInValues .for> (
IN aValue
aValue .Name .AddToArray: g_MixInValues
[ cUnderline aValue .Name cUnderline ' = ' aValue .Target .TypeName ';' ] .Out
)
VAR l_Parent
Self .CalcParentAndInclude >>> l_Parent
if ( Self .UPisTrue "need UC" ) then
begin
Self .UserCode: 'cit' ()
end // ( Self .UPisTrue "need UC" )
[
Self .TypeName
' = '
Self .Abstraction CASE
at_abstract
[ cOpenComment 'abstract' cCloseComment cSpace ]
at_final
[ cOpenComment 'final' cCloseComment cSpace ]
END // CASE
'class'
ARRAY VAR l_Implements
[] >>> l_Implements
VAR l_WasComma
false >>> l_WasComma
l_Parent .ToArray
.join> (
Self .ClassImplements
.filter> (
IN anItem
if ( anItem .NotInArray: l_Implements ) then
begin
anItem .AddToArray: l_Implements
true
end // ( anItem .NotInArray: l_Implements )
else
begin
false
end // ( anItem .NotInArray: l_Implements )
) // .filter>
) // .join>
.With()> (
IN anItem
RULES
( anItem .IsMixIn )
( anItem .TypeName .WithComma: l_WasComma .KeepInStack )
DEFAULT
begin
anItem .IfDefBraceLn:
(
anItem .TypeName .WithComma: l_WasComma .KeepInStack
) // anItem .IfDefBraceLn:
end // DEFAULT
; // RULES
) // .With()>
] .Out
Self .OutDocumentation
Self .OutClassInner
[ 'end;//' Self .TypeName ] .Out
Self .UndefineImplementedMixInValues
; // OutClass
elem_proc OutInterfaceBody
Indented: (
VAR l_Ops
Self .AllOperationsForDefine >>> l_Ops
VAR l_AllOps
Self .AllOperationsForOverload >>> l_AllOps
l_Ops .for> .MethodInterfaceFor: l_AllOps
Self .InterfaceProperties .for> .OutProperty
) // Indented:
; // OutInterfaceBody
elem_proc OutInterface
Self .DefineMixInValues
Self .MixInValues .for> (
IN aValue
[ '//' cUnderline aValue .Name cUnderline ' = ' aValue .Target .TypeName ';' ] .Out
) // Self .MixInValues .for>
[ Self .TypeName ' = interface' Self .MainAncestor .TypeName .With() ] .Out
Self .OutDocumentation
VAR l_GUID
Self .GUID >>> l_GUID
if ( l_GUID .IsNotNil ) then
begin
Indented: ( [ '[' cQuote cOpenComment l_GUID cCloseComment cQuote ']' ] .Out )
end // ( l_GUID .IsNotNil )
Self .OutInterfaceBody
[ 'end;//' Self .TypeName ] .Out
Self .UndefineMixInValues
; // OutInterface
elem_proc OutRecord
[
Self .TypeName ' = '
Self .UPisTrue "packed" ? 'packed '
'record'
] .Out
Self .OutDocumentation
Indented: (
VAR l_Switch
Self .Attributes
.filter> ( .IsStereotype st_switch::Attribute )
.FirstElement
>>> l_Switch
if ( l_Switch .IsNotNil ) then
begin
[
'Case '
if ( l_Switch .Name 'void' != ) then
begin
l_Switch .Name ': '
end // ( l_Switch .Name 'void' != )
l_Switch .Target .TypeName
' of'
] .Out
Indented: (
Self .Fields .for> (
IN aField
[
VAR l_Value
aField .GetUP 'Value' >>> l_Value
if ( l_Value .IsValueValid ) then
l_Value
else
'!!!'
': '
'('
if ( 'void' aField .Name StartsStr ) then
begin
VAR l_WasField
false >>> l_WasField
aField .Target .Fields .for> (
IN aField
if l_WasField then
'; '
aField .Name
': '
aField .Target .TypeName
true >>> l_WasField
) // aField .Target .Fields .for>
end // ( 'void' aField .Name StartsStr )
else
begin
aField .Name
': '
aField .Target .TypeName
end // ( 'void' aField .Name StartsStr )
');'
] .Out? ? (
aField .OutDocumentation
) // .Out? ?
) // Self .Fields .for>
) // Indented:
end // ( l_Switch .IsNotNil )
else
begin
Self .Fields .for> .OutField
end // ( l_Switch .IsNotNil )
) // Indented:
if ( Self .UPisTrue "need UC" ) then
begin
Self .UserCode: 'publ' ()
end // ( Self .UPisTrue "need UC" )
[ 'end;//' Self .TypeName ] .Out
; // OutRecord
elem_proc OutDefine
[ cOpenComment '$Define ' Self .Name cCloseComment ] .Out
; // OutDefine
elem_proc OutUndef
[ cOpenComment '$Undef ' Self .Name cCloseComment ] .Out
; // OutUndef
elem_proc OutStaticObject
if ( Self .IsConstructorsHolder ! ) then
begin
if ( Self .UPisTrue "need UC" ) then
begin
Self .UserCode: 'ci' ()
end // ( Self .UPisTrue "need UC" )
[
Self .TypeName ' = '
Self .UPisTrue "packed" ? 'packed '
'object' Self .MainAncestor .TypeName .With()
] .Out
Self .OutDocumentation
Self .OutClassInner
[ 'end;//' Self .TypeName ] .Out
end // ( Self .IsConstructorsHolder ! )
; // OutStaticObject
elem_proc OutPureMixIn
'(*' .Out
Self .OutInterface
'*)' .Out
; // OutPureMixIn
ANY elem_func ExtValueOrName
Self .ExtValue >>> Result
if ( Result .IsValueValid ! ) then
begin
Self .Name >>> Result
end // ( Result .IsValueValid !
; // ExtValueOrName
elem_proc OutRange
[ Self .TypeName
' = '
VAR l_First
Self .FirstAttribute >>> l_First
VAR l_Second
Self .SecondAttribute >>> l_Second
if ( l_Second .IsNil ) then
begin
l_First >>> l_Second
end // ( l_Second .IsNil )
VAR l_ElementPrefix
if ( Self .GetUP "elements prefix" '<none>' == ) then
begin
'' >>> l_ElementPrefix
end
else
begin
Self .MainAncestor .GetUP 'extprop:pas:ElementPrefix' >>> l_ElementPrefix
end
: .ValueWithPrefix
IN aValue
if ( aValue IsString ! ) then
aValue
else
if ( l_ElementPrefix aValue StartsStr ) then
aValue
else
begin
l_ElementPrefix aValue
end
; // .ValueWithPrefix
l_First .ExtValueOrName .ValueWithPrefix
' .. '
l_Second .ExtValueOrName .ValueWithPrefix
';'
] .Out
Self .OutDocumentation
; // OutRange
elem_proc OutTypedef
ModelElement VAR l_MainAncestor
Self .MainAncestor >>> l_MainAncestor
[ Self .TypeName
' = '
if ( Self .UPisTrue "newRTTI" ) then
'type '
if ( Self .IsPointer ) then
'^'
if ( Self .IsClassRef ) then
begin
true >>> g_WasForwarded
'class of '
end // ( Self .IsClassRef )
if ( Self .IsPointer ! ) then
begin
STRING VAR l_OtherUnit
l_MainAncestor .EffectiveUnitName >>> l_OtherUnit
if ( l_OtherUnit .IsNotNil ) then
begin
if ( Self .TypeName l_MainAncestor .TypeName SameText ) then
begin
STRING VAR l_OurUnit
Self .EffectiveUnitName >>> l_OurUnit
if ( l_OurUnit l_OtherUnit != ) then
begin
l_OtherUnit cDot
end // l_OurUnit l_OtherUnit !=
end // Self .TypeName l_MainAncestor .TypeName ==
end // l_OtherUnit .IsNotNil
end // Self .IsPointer !
l_MainAncestor .TypeName
';'
] .Out
Self .OutDocumentation
; // OutTypedef
elem_proc OutEnum
[ Self .TypeName ' = (' ] .Out
Self .OutDocumentation
STRING VAR l_Prefix
Self .GetUP 'extprop:pas:ElementPrefix' >>> l_Prefix
VAR l_NeedComma
false >>> l_NeedComma
Indented: (
Self .Attributes .for> (
IN aChild
aChild .IfDef:
(
[
l_Prefix aChild .Name
VAR l_Value
aChild .ExtValue >>> l_Value
if ( l_Value .IsValueValid ) then
begin
' = ' l_Value ToPrintable
end // ( l_Value .IsValueValid )
] strings:Cat
.WithComma: l_NeedComma .Out
aChild .OutDocumentation
) // aChild .IfDef:
) // Self .Attributes .for>
) // Indented:
[ ');//' Self .TypeName ] .Out
; // OutEnum
elem_proc OutSetOf
[ Self .TypeName ' = set of ' Self .MainAncestor .TypeName ';' ] .Out
Self .OutDocumentation
; // OutSetOf
elem_proc OutFunction
Self .MethodInterfaceEx: (
Self .TypeName
' = '
) () (
if ( Self .UPisTrue "of object" ) then
begin
' of object'
end // ( Self .UPisTrue "of object" )
)
( IN aMethod )
; // OutFunction
elem_proc OutArray
if ( Self .IsOpenArray ! ) then
begin
[
Self .TypeName ' = array '
if ( Self .MainAncestor .IsNotNil ) then
begin
'[' Self .MainAncestor .TypeName '] '
end // ( Self .MainAncestor .IsNotNil )
'of '
Self .FirstAttribute .Target .TypeName ';'
] .Out
Self .OutDocumentation
end // ( Self .IsOpenArray ! )
; // OutArray
ARRAY CompileTime-VAR g_OutedTypes nil
ARRAY CompileTime-VAR g_ForwardedTypes nil
elem_proc OutTypeKeyword
: DoOutTypeKeyword
if ( g_WasType ! ) then
begin
'type' .Out
true >>> g_WasType
Self >>> g_WasTypeOpener
false >>> g_WasConst
end // g_WasType !
; // DoOutTypeKeyword
RULES
( Self .IsType )
DoOutTypeKeyword
( Self .IsMixIn )
begin
if g_WasConst then
DoOutTypeKeyword
end // ( Self .IsMixIn )
; // RULES
; // OutTypeKeyword
elem_proc OutForward
if ( Self .NotInArray: g_OutedTypes ) then
begin
if ( Self .NotInArray: g_ForwardedTypes ) then
begin
Self .AddToArray: g_ForwardedTypes
RULES
( Self .IsPureMixIn )
()
DEFAULT
begin
Self .IfDef: (
Self .OutTypeKeyword
Indented: (
RULES
( Self .IsClass )
(
true >>> g_WasForwarded
[ Self .TypeName ' = class;' ] .Out OutLn
)
( Self .IsInterface )
(
true >>> g_WasForwarded
[ Self .TypeName ' = interface;' ] .Out OutLn
)
; // RULES
) // Indented:
) // Self .IfDef:
end // DEFAULT
; // RULES
end // ( Self .NotInArray: g_ForwardedTypes )
end // ( Self .NotInArray: g_OutedTypes )
; // OutForward
BOOLEAN elem_func SomeOwnChildrenInheritsOrImplementsMixIn
RULES
(
Self .ChildrenWithoutOwnFile
.filter> .InheritsOrImplementsMixIn
.NotEmpty
)
true
DEFAULT
false
; // RULES
>>> Result
; // SomeOwnChildrenInheritsOrImplementsMixIn
elem_iterator ForwardedEx
Self .Forwarded
RULES
( Self .IsPureMixIn )
()
( Self .IsTypedef )
()
( Self .IsInterface )
begin
RULES
( Self .Parent .IsInterface )
( .join> ToArray: ( Self .Parent ) )
( Self .Parent .IsClass )
RULES
( Self .Parent .IsService )
()
( Self .Parent .InheritsOrImplementsMixIn )
()
( Self .Parent .SomeOwnChildrenInheritsOrImplementsMixIn )
()
DEFAULT
( .join> ToArray: ( Self .Parent ) )
; // RULES
; // RULES
end // ( Self .IsInterface )
; // RULES
//.joinWithLambded> ( Self .AllOwnChildren ) call.me
>>> Result
; // ForwardedEx
elem_proc OutForwarded
Self .ForwardedEx .for> .OutForward
; // OutForwarded
elem_proc OutType
RULES
( Self .IsElementProxy )
()
( Self .IsUtilityPack )
()
( Self .IsInterfaces )
()
( Self .IsTarget )
()
( Self .IsOpenArray )
()
( ( Self .IsStaticObject ) AND ( Self .IsConstructorsHolder ) )
()
( Self .IsUserType )
()
( Self .IsTestClass )
()
( Self .IsVCMOperations )
()
( Self .IsConstantsButNotType )
()
( Self .IsTestUnit )
()
( Self .IsUnit )
()
( Self .IsImpl )
()
( Self .IsTestLibrary )
()
DEFAULT
(
if ( Self .NotInArray: g_OutedTypes ) then
begin
Self .AddToArray: g_OutedTypes
Self .OutForwarded
Self .IfDef:
(
Self .OutTypeKeyword
Indented: (
RULES
( Self .IsSetOf )
( Self .OutSetOf )
( Self .IsArray )
( Self .OutArray )
( Self .IsEnum )
( Self .OutEnum )
( Self .IsRange )
( Self .OutRange )
( Self .IsTypedef )
( Self .OutTypedef )
( Self .IsException )
( Self .OutClass )
( Self .IsMixIn )
( Self .OutClass )
//( Self .IsTestClass )
// ( Self .OutClass )
( Self .IsClass )
( Self .OutClass )
( Self .IsPureMixIn )
( Self .OutPureMixIn )
( Self .IsInterface )
( Self .OutInterface )
( Self .IsStaticObject )
( Self .OutStaticObject )
( Self .IsUnion )
( Self .OutRecord )
( Self .IsRecord )
( Self .OutRecord )
( Self .IsUndef )
( Self .OutUndef )
( Self .IsDefine )
( Self .OutDefine )
( Self .IsFunction )
( Self .OutFunction )
DEFAULT
( [ '// ' Self .TypeName ] .Out )
; // RULES
) // Indented:
OutLn
) // Self .IfDef:
end // ( Self .NotInArray: g_OutedTypes )
) // DEFAULT
; // RULES
; // OutType
BOOLEAN elem_func NeedForwarded
RULES
( Self .IsType )
true
( Self .IsPureMixIn )
true
DEFAULT
false
; // RULES
>>> Result
; // NeedForwarded
elem_proc OutChildrenRecPrim
IN aValid
IN aOut
IN aNeedIfDef
elem_proc DoOut
if ( aNeedIfDef
AND ( Self .NeedForwarded )
AND ( Self aValid DO )
) then
begin
Self .OutForwarded
Self .IfDef:
(
if ( Self .InheritsOrImplementsMixIn ! ) then
begin
if ( Self .SomeOwnChildrenInheritsOrImplementsMixIn ! ) then
begin
Self .ConstantsAndChildrenWithoutOwnFile
.filter> ( Self .InheritsFrom )
.for> .OutForward
end // ( Self .SomeOwnChildrenInheritsOrImplementsMixIn ! )
end // ( Self .InheritsOrImplementsMixIn ! )
Self .ConstantsAndChildrenWithoutOwnFile
.filter> ( Self .InheritsFrom ! )
.for> call.me
if ( Self aValid DO ) then
begin
Self aOut DO
end // ( Self aValid DO )
Self .ConstantsAndChildrenWithoutOwnFile
.filter> ( Self .InheritsFrom )
.for> call.me
) // Self .IfDef:
end // ( Self .IsType )
else
begin
Self .ConstantsAndChildrenWithoutOwnFile
.filter> ( Self .InheritsFrom ! )
.for> call.me
if ( Self aValid DO ) then
begin
Self aOut DO
end // ( Self aValid DO )
Self .ConstantsAndChildrenWithoutOwnFile
.filter> ( Self .InheritsFrom )
.for> call.me
end // ( Self .IsType )
; // DoOut
Self .DoOut
; // OutChildrenRecPrim
elem_proc OutChildrenRec
IN aValid
IN aOut
Self aValid aOut false .OutChildrenRecPrim
; // OutChildrenRec
elem_proc OutTypeRec
IN aValid
IN aOut
Self aValid aOut true .OutChildrenRecPrim
; // OutTypeRec
elem_proc OutChildrenRec:
^ IN aValid
^ IN aOut
Self aValid aOut .OutChildrenRec
; // OutChildrenRec:
WordAlias .ForChildren> .OutChildrenRec:
elem_proc OutTypes
^ IN aValid
DropWasType
: DoOutType
IN aChild
//aChild .IfDef:
(
aChild .OutType
) // aChild .IfDef:
; // DoOutType
/*{
Self @ (
IN aChild
aChild aValid DO
AND ( aChild .IsEnum )
) @ DoOutType .OutTypeRec
Self @ (
IN aChild
aChild aValid DO
AND ( aChild .IsSetOf )
) @ DoOutType .OutTypeRec
}*/
Self @ (
IN aChild
aChild aValid DO
AND ( aChild .UPisTrue "is default ancestor" )
) @ DoOutType .OutTypeRec
Self @ (
IN aChild
aChild aValid DO
AND ( aChild .IsPointer )
) @ DoOutType .OutTypeRec
Self @ (
IN aChild
aChild aValid DO
AND ( aChild .IsClassRef )
) @ DoOutType .OutTypeRec
/*{
Self @ (
IN aChild
aChild aValid DO
AND ( aChild .IsPureMixIn )
) @ DoOutType .OutTypeRec
}*/
Self @ (
IN aChild
aChild aValid DO
) @ DoOutType .OutTypeRec
; // OutTypes
elem_proc OutConstants
RULES
( Self .IsConstantArray )
(
VAR l_MainAncestor
[
Self .Name
': array '
'['
VAR l_MainImplements
Self .MainImplements >>> l_MainImplements
if ( l_MainImplements .IsNil ) then
begin
'0 .. ' Self .Attributes .CountIt 1 -
end // ( l_MainImplements .IsNil )
else
begin
l_MainImplements .TypeName
end // ( l_MainImplements .IsNil )
']'
' of '
Self .MainAncestor >>> l_MainAncestor
l_MainAncestor .TypeName
' = ('
] .Out
VAR l_WasComma
false >>> l_WasComma
VAR l_IsPointer
l_MainAncestor .IsPointer >>> l_IsPointer
Self .Attributes
/*{ .map> (
.ExtValue
if l_IsPointer then
begin
'@'
SWAP
Cat
end // l_IsPointer
) }*/
.for> (
IN anItem
anItem .IfDef:
(
(
anItem .ExtValue
if l_IsPointer then
begin
'@'
SWAP
Cat
end // l_IsPointer
)
.WithComma: l_WasComma .Out
) // anItem .IfDef:
)
[
');'
] .Out
) // ( Self .IsConstantArray )
( Self .IsSetConst )
(
[
Self .Name ' = '
RULES
( Self .Attributes .NotEmpty )
(
STRING VAR l_Prefix
Self .MainAncestor .GetUP 'extprop:pas:ElementPrefix' >>> l_Prefix
VAR l_WasComma
false >>> l_WasComma
'['
Self .Attributes
.map> .ExtValue
.filter> .IsValueValid
.map> ( l_Prefix SWAP Cat )
.for> (
.WithComma: l_WasComma .KeepInStack
) // .for>
']'
)
( Self .MainAncestor .IsSetConst )
(
if ( Self .EffectiveUnitName Self .MainAncestor .EffectiveUnitName != ) then
begin
Self .MainAncestor .EffectiveUnitName cDot
end // ( Self .EffectiveUnitName Self .MainAncestor .EffectiveUnitName != )
Self .MainAncestor .Name
)
DEFAULT
(
VAR l_MainAncestor
Self .MainAncestor >>> l_MainAncestor
if ( l_MainAncestor .IsSetOf ) then
begin
l_MainAncestor .MainAncestor >>> l_MainAncestor
end // ( l_MainAncestor .IsSetOf )
'[' 'Low(' l_MainAncestor .TypeName ')' ' .. ' 'High(' l_MainAncestor .TypeName ')' ']'
)
; // RULES
';'
] .Out
) // ( Self .IsSetConst )
DEFAULT
(
STRING VAR l_Prefix
Self .GetUP 'extprop:pas:ElementPrefix' >>> l_Prefix
Self .Attributes .for> (
IN anItem
anItem .IfDef:
(
[
l_Prefix anItem .Name
if ( anItem .UPisTrue "is define" ! ) then
begin
VAR l_Type
anItem .Target >>> l_Type
l_Type .IsNotNil ? ( ': ' l_Type .TypeName )
end // ( anItem .UPisTrue "is define" ! )
BOOLEAN VAR l_NeedSuffix
false >>> l_NeedSuffix
VAR l_Value
anItem .ExtValue >>> l_Value
if ( l_Value .IsValueValid ! ) then
begin
anItem .GetUP 'Value' >>> l_Value
true >>> l_NeedSuffix
end
' = ' l_Value
if l_NeedSuffix then
begin
VAR l_Suffix
anItem .GetUP "suffix expr" >>> l_Suffix
if ( l_Suffix .IsValueValid ) then
begin
cSpace l_Suffix
end // ( l_Suffix .IsValueValid )
end // l_NeedSuffix
';'
] .Out? ? (
anItem .OutDocumentation
) // ] .Out? ?
) // anItem .IfDef:
) // Self .Attributes .for>
) // DEFAULT
; // RULES
; // OutConstants
PROCEDURE .OutConstantsList
ARRAY IN aList
BOOLEAN VAR l_WasConst
false >>> l_WasConst
aList .for> (
IN anItem
RULES
( anItem .IsLocalConst )
()
DEFAULT
(
if ( l_WasConst ! ) then
begin
true >>> l_WasConst
true >>> g_WasConst
DropWasType
'const' .Out
end
anItem .IfDef:
(
anItem .OutDocumentation
Indented: (
anItem .OutConstants
) // Indented:
) // anItem .IfDef:
) // DEFAULT
; // RULES
)
if l_WasConst then
OutLn
; // .OutConstantsList
INTEGER elem_func ConstantsListVisibility
Cached:
(
RULES
( Self .IsNil )
PrivateAccess
( Self .IsConstantArray )
(
INTEGER VAR l_Vis
Self .Visibility >>> l_Vis
RULES
( l_Vis PublicAccess == )
(
VAR l_MainImplements
Self .MainImplements >>> l_MainImplements
RULES
( l_MainImplements .IsNotNil )
(
RULES
( Self .UnitProducer l_MainImplements .UnitProducer == )
ProtectedAccess
DEFAULT
l_Vis
; // RULES
)
DEFAULT
l_Vis
; // RULES
) // ( l_Vis PublicAccess == )
DEFAULT
l_Vis
; // RULES
) // ( Self .IsConstantArray )
( Self .IsLocalConst )
( Self .Visibility )
( Self .IsSetConst )
(
INTEGER VAR l_Vis
Self .Visibility >>> l_Vis
RULES
( l_Vis PublicAccess == )
ProtectedAccess
DEFAULT
l_Vis
; // RULES
) // ( Self .IsSetConst )
( Self .IsConstants )
(
INTEGER VAR l_Vis
Self .Visibility >>> l_Vis
RULES
( l_Vis PublicAccess == )
(
BOOLEAN VAR l_Protected
Self .Attributes
.mapToTarget>
.filterNil>
.filter> (
.UnitProducer Self .UnitProducer .IsSameModelElement
)
.NotEmpty
>>> l_Protected
if ( l_Protected ! ) then
begin
Self .Attributes
.map> .ValueType
.filterNil>
.filter> (
.UnitProducer Self .UnitProducer .IsSameModelElement
)
.NotEmpty
>>> l_Protected
end // ( l_Protected ! )
RULES
l_Protected
ProtectedAccess
DEFAULT
l_Vis
; // RULES
) // ( l_Vis PublicAccess == )
DEFAULT
l_Vis
; // RULES
) // ( Self .IsConstants )
DEFAULT
( Self .Visibility )
; // RULES
)
>>> Result
; // ConstantsListVisibility
elem_proc OutDefinitionsSection:
^ IN aValid
: .Suitable aValid DO ;
Self .ForChildren> .Suitable (
.ConstantsEx .filter> ( .ConstantsListVisibility PublicAccess == ) .OutConstantsList
)
Self .OutTypes .Suitable
Self .ForChildren> .Suitable (
.ConstantsEx .filter> ( .ConstantsListVisibility ProtectedAccess == ) .OutConstantsList
)
; // OutDefinitionsSection:
elem_iterator GlobalOperationsForOverload
RULES
( ( Self .IsStaticObject ) AND ( Self .IsConstructorsHolder ) )
( ( Self .MainAncestor .GlobalOperations ) .join> ( Self .GlobalOperations ) )
DEFAULT
( Self .GlobalOperations )
; // RULES
>>> Result
; // GlobalOperationsForOverload
elem_proc OutVar
Self .IfDef:
(
[
'var '
if ( Self .IsGlobalVar ) then
'g_'
else
if ( Self .IsLocalVar ) then
'l_'
Self .Name
': '
if ( Self .Target .IsMethod ) then
begin
Self .Target .MainAncestor .TypeName
' = ' Self .Target .MethodName
end // ( Self .Target .IsMethod )
else
begin
Self .Target .TypeName
if ( Self .UPisTrue "IsResult" ) then
begin
' absolute Result'
end // ( Self .UPisTrue "IsResult" )
VAR l_Value
Self .ExtValue >>> l_Value
if ( l_Value .IsValueValid ) then
begin
' = ' l_Value
end // ( l_Value .IsValueValid )
end // ( Self .Target .IsMethod )
';'
] .Out
Self .OutDocumentation
) // Self .IfDef:
; // OutVar
elem_proc OutInterfaceSection
Self .OutDefinitionsSection: .IsForInterface
VAR l_WasOut
false >>> l_WasOut
Self .ForChildren> .IsForInterface (
IN anItem
VAR l_GlobalOperations
anItem .GlobalOperations >>> l_GlobalOperations
VAR l_GlobalOperationsForOverload
anItem .GlobalOperationsForOverload >>> l_GlobalOperationsForOverload
l_GlobalOperations
.filter> ( .Visibility PrivateAccess != )
.for> .MethodInterfaceForEx: l_GlobalOperationsForOverload ( IN aMethod true >>> l_WasOut )
)
l_WasOut ? OutLn
false >>> l_WasOut
Self .ForChildren> .IsForInterface (
.GlobalVars
.filter> ( .Visibility PrivateAccess != )
.for> ( .OutVar true >>> l_WasOut )
)
l_WasOut ? OutLn
; // OutInterfaceSection
elem_iterator LocalMethods
Self .OperationsEx
.filter> .IsLocalMethod
>>> Result
; // LocalMethods
elem_iterator LocalVars
Self .Attributes
.filter> .IsLocalVar
.filter> ( .IsGlobalVar ! )
>>> Result
; // LocalVars
elem_proc MethodBody
if ( Self .UPisTrue 'extprop:isAsm' ) then
begin
'asm' .Out
' jmp l3LocalStub' .Out
end
else
begin
if ( Self .IsIteratorF ! ) then
begin
TF g_MethodParentPrefix (
'' >>> g_MethodParentPrefix
Self .LocalVars .for> .OutVar
Indented:
(
Self .LocalMethods .for> (
IN aMethod
OutLn
aMethod .MethodInterfaceForEx: nil ( call.me )
) // Self .LocalMethods .for>
) // Indented:
) // TF g_MethodParentPrefix
end // ( Self .IsIteratorF ! )
Self .UserCode: cVarUserCodeSuffix ()
'begin' .Out
VAR l_WasOut
false >>> l_WasOut
if ( Self .IsIteratorF ! ) then
begin
Indented:
(
Self .Dependencies
.filter> ( .IsStereotype st_call::Dependency )
.filter> ( .Target .IsIterator )
.for> (
IN aDep
Self .UserCode: 'iter' ()
VAR l_Target
aDep .Target >>> l_Target
VAR l_NeedsParams
aDep .UPisTrue "iterator needs params" >>> l_NeedsParams
if l_NeedsParams then
begin
if ( l_Target .MethodParameters .filter> .IsInParam .IsEmpty ) then
begin
false >>> l_NeedsParams
end // ( l_Target .MethodParameters .filter> .IsInParam .IsEmpty )
end // l_NeedsParams
VAR l_NeedsAfter
aDep .UPisTrue "needs after iterator UC" >>> l_NeedsAfter
[
if ( l_Target .IsServiceIterator ) then
begin
l_Target .Parent .TypeName '.Instance.'
end // ( l_Target .IsServiceIterator )
VAR l_Name
l_Target .MethodName >>> l_Name
l_Name
if ( 'F' l_Name EndsStr ! ) then
'F'
'('
l_Target .IteratorStub .MethodName
'('
'@'
VAR l_IteratorFuncName
aDep .GetUP "iterator func name" >>> l_IteratorFuncName
if ( l_IteratorFuncName .IsNil ) then
begin
'DoIt' >>> l_IteratorFuncName
end // ( l_IteratorFuncName .IsNil )
l_IteratorFuncName
')'
if ( l_NeedsParams ! ) then
begin
')'
if ( l_NeedsAfter ! ) then
';'
end // ( l_NeedsParams ! )
] .Out
if l_NeedsParams then
begin
Self .UserCode: 'iterparam' ()
[
')'
if ( l_NeedsAfter ! ) then
';'
] .Out
end // l_NeedsParams
if l_NeedsAfter then
begin
Self .UserCode: 'afteriter' ()
end // l_NeedsAfter
true >>> l_WasOut
) // .for>
) // Indented:
end // ( Self .IsIteratorF ! )
if ( l_WasOut ! ) then
begin
Self .UserCode: cImplementationUserCodeSuffix ( ' !!! Needs to be implemented !!!' )
end // ( l_WasOut ! )
end
[ 'end;//' g_MethodParentPrefix Self .MethodNamePrefix Self .MethodName ] .Out
OutLn
; // MethodBody
BOOLEAN elem_func NeedsInstanceR
Cached:
(
RULES
( Self .UPisTrue "needs InstanceR" )
true
( Self .InheritsEx .filter> call.me .NotEmpty )
true
( Self .ImplementsEx .filter> call.me .NotEmpty )
true
DEFAULT
false
; // RULES
)
>>> Result
; // NeedsInstanceR
elem_proc OutClassImplementation
Self .IfDef:
(
Self .DefineImplementedMixInValues
if ( Self .ImplementsMixIn ) then
begin
if ( Self .AllInlinedOperations .NotEmpty ) then
begin
Self .OutOtherMixinValues
end // ( Self .AllInlinedOperations .NotEmpty )
end // ( Self .ImplementsMixIn )
TF g_Implementor (
Self >>> g_Implementor
BOOLEAN VAR l_WasFirst
false >>> l_WasFirst
TF g_EnableAutoEOL (
false >>> g_EnableAutoEOL
TF g_EnableMethodDocumentation (
false >>> g_EnableMethodDocumentation
Self .AllInlinedOperations
.filter> (
IN aMethod
if l_WasFirst then
true
else
begin
true >>> l_WasFirst
false
end
) // .filter>
.for> .MethodInterfaceForEx: nil (
IN aMethod
' forward;' .Out
OutLn
OutLn
) // .for> .MethodInterfaceForEx: nil
) // TF g_EnableMethodDocumentation
) // TF g_EnableAutoEOL
Self .AllInlinedOperations .for> .MethodInterfaceForEx: nil .MethodBody
) // TF g_Implementor
VAR l_WasInstanceR
Self .IsMixIn >>> l_WasInstanceR
Self .InheritsEx
.join> ( Self .ImplementsEx )
.filter> .IsMixIn
.for> (
IN aG
if ( l_WasInstanceR ! ) then
begin
if ( aG .NeedsInstanceR ) then
begin
true >>> l_WasInstanceR
[ 'type _Instance_R_ = ' Self .TypeName ';' ] .Out
OutLn
end // ( aG .NeedsInstanceR )
end // ( l_WasInstanceR ! )
aG .OutMixInInclude
OutLn
) // .for>
TF g_Implementor (
Self >>> g_Implementor
TF g_MethodParentPrefix (
Self .TypeName >>> g_MethodParentPrefix
g_MethodParentPrefix cDot Cat >>> g_MethodParentPrefix
TF g_EnableMethodDirectives (
false >>> g_EnableMethodDirectives
Self .AllOperationsForDefine
.filter> ( .MethodAbstraction at_abstract != )
.for> .MethodInterfaceForEx: nil .MethodBody
) // TF g_EnableMethodDirectives
) // TF g_MethodParentPrefix
) // TF g_Implementor
if ( Self .UPisTrue "need UC" ) then
begin
Self .UserCode: 'impl' ()
OutLn
end // ( Self .UPisTrue "need UC" )
Self .UndefineImplementedMixInValues
) // Self .IfDef:
; // OutClassImplementation
elem_proc OutTestClassImplementation
elem_proc MethodBody
Self .UserCode: cVarUserCodeSuffix ()
'begin' .Out
' with Self do' .Out
' begin' .Out
Self .UserCode: cImplementationUserCodeSuffix ( ' !!! Needs to be implemented !!!' )
' end;//with Self' .Out
[ 'end;//' g_MethodParentPrefix Self .MethodNamePrefix Self .MethodName ] .Out
OutLn
; // MethodBody
elem_iterator ParamsOrKeys
if ( Self .IsProperty ) then
( Self .PropertyKeys )
else
( Self .MethodParameters )
.filter> ( 'Self' .HasName ! )
>>> Result
; // ParamsOrKeys
elem_iterator OperationsAndProperties
Self .OperationsEx
.join> ( Self .Properties )
>>> Result
; // OperationsAndProperties
TF g_MethodParentPrefix (
Self .TypeName >>> g_MethodParentPrefix
g_MethodParentPrefix cUnderline Cat >>> g_MethodParentPrefix
Self .OperationsAndProperties .for> .MethodInterfaceForEx: nil .MethodBody
[ 5 6 ] .for> (
IN aNum
STRING elem_func ToVariant
RULES
( Self .IsSimpleClass )
( [ 'tc' aNum IntToStr 'PublicInfo.VarFromObject' ] strings:Cat )
DEFAULT
''
; // RULES
>>> Result
; // ToVariant
STRING elem_func FromVariant
RULES
( Self .Name 'String' == )
'__coerce_String'
( Self .Name 'AnsiString' == )
'__coerce_String'
DEFAULT
'OleVariant'
; // RULES
>>> Result
; // ToVariant
Self .OperationsAndProperties .for> (
IN aMethod
if ( aMethod .IsWriteonlyProperty ! ) then
begin
VAR l_MethodName
[
g_MethodParentPrefix
if ( aMethod .IsProperty ) then
'Get_'
aMethod .Name
] strings:Cat >>> l_MethodName
[ 'procedure ' l_MethodName '_Pub' aNum '(Instance: TObject; Args: PVariantArgList; out Value: OleVariant; Cookie: Cardinal); stdcall;' ] .Out
'begin' .Out
[ ' Assert(Instance is ' Self .MainAncestor .TypeName ');' ] .Out
' try' .Out
[ ' '
if ( aMethod .MethodType .IsNotNil ) then
begin
'Value := ' aMethod .MethodType .ToVariant '('
end // ( aMethod .MethodType .IsNotNil )
l_MethodName
'('
Self .EffectiveType .TypeName '(' 'Instance' ')'
VAR l_Index
0 >>> l_Index
aMethod .ParamsOrKeys .for> (
IN aParam
', '
aParam .Target .FromVariant
'('
'Args^['
l_Index
']'
')'
INC l_Index
) // aMethod .ParamsOrKeys .for>
')'
if ( aMethod .MethodType .IsNotNil ) then
')'
';'
] .Out
' except' .Out
' // - гасим исключения' .Out
if ( aMethod .MethodType .IsNotNil ) then
begin
' Value := Unassigned;' .Out
end // ( aMethod .MethodType .IsNotNil )
' end;//try..except' .Out
'end;' .Out
OutLn
end // ( aMethod .IsWriteonlyProperty ! )
if ( aMethod .IsProperty ) then
if ( aMethod .IsReadonlyProperty ! ) then
begin
VAR l_MethodName
[
g_MethodParentPrefix
'Set_'
aMethod .Name
] strings:Cat >>> l_MethodName
[ 'procedure ' l_MethodName '_Pub' aNum '(Instance: TObject; Args: PVariantArgList; out Value: OleVariant; Cookie: Cardinal); stdcall;' ] .Out
'begin' .Out
[ ' Assert(Instance is ' Self .MainAncestor .TypeName ');' ] .Out
' try' .Out
[ ' '
l_MethodName
'('
Self .EffectiveType .TypeName '(' 'Instance' ')'
', '
aMethod .Target .FromVariant
'('
'Args^['
0
']'
')'
')'
';'
] .Out
' except' .Out
' // - гасим исключения' .Out
' end;//try..except' .Out
'end;' .Out
OutLn
end // ( aMethod .IsReadonlyProperty ! )
) // Self .OperationsAndProperties .for>
[ 'procedure _RegisterPublicInformation' aNum ';' ] .Out
'begin' .Out
Self .OperationsAndProperties .for> (
IN aMethod
if ( aMethod .IsWriteonlyProperty ! ) then
begin
VAR l_MethodName
[
g_MethodParentPrefix
if ( aMethod .IsProperty ) then
'Get_'
aMethod .Name
'_Pub'
aNum IntToStr
] strings:Cat >>> l_MethodName
[
' ' 'tc' aNum 'PublicInfo._RegisterMethod'
'('
Self .MainAncestor .TypeName
', '
'tc' aNum 'OpenAppClasses' cDot
if ( aMethod .IsProperty ) then
'mtGet'
else
'mtInvoke'
', '
cQuote aMethod .Name cQuote
', '
if ( aMethod .MethodType .IsNil ) then
'nil'
else
begin
'TypeInfo(' aMethod .MethodType .TypeName ')'
end
', '
'['
(
VAR l_WasComma
false >>> l_WasComma
aMethod .ParamsOrKeys .map> ( .Target .TypeName 'TypeInfo(' SWAP Cat ')' Cat ) .for> (
.WithComma: l_WasComma .KeepInStack
)
)
']'
', '
'['
(
VAR l_WasComma
false >>> l_WasComma
aMethod .ParamsOrKeys .map> ( .Name cQuote SWAP Cat cQuote Cat ) .for> (
.WithComma: l_WasComma .KeepInStack
)
)
']'
', '
l_MethodName
')' ';'
] .Out
end // ( aMethod .IsWriteonlyProperty ! )
if ( aMethod .IsProperty ) then
if ( aMethod .IsReadonlyProperty ! ) then
begin
VAR l_MethodName
[
g_MethodParentPrefix
'Set_'
aMethod .Name
'_Pub'
aNum IntToStr
] strings:Cat >>> l_MethodName
[
' ' 'tc' aNum 'PublicInfo._RegisterMethod'
'('
Self .MainAncestor .TypeName
', '
'tc' aNum 'OpenAppClasses' cDot
'mtPut'
', '
cQuote aMethod .Name cQuote
', '
'nil'
', '
'['
']'
', '
'['
']'
', '
l_MethodName
')' ';'
] .Out
end // ( aMethod .IsReadonlyProperty ! )
) // Self .OperationsAndProperties .for>
'end;' .Out
OutLn
) // [ 5 6 ] .for>
) // TF g_MethodParentPrefix
; // OutTestClassImplementation
elem_proc OutImplementation
RULES
( Self .IsClassOrMixIn )
( Self .OutClassImplementation )
( Self .IsStaticObject )
( Self .OutClassImplementation )
( Self .IsException )
( Self .OutClassImplementation )
( Self .IsTestClass )
( Self .OutTestClassImplementation )
; // RULES
; // OutImplementation
elem_proc OutIniOrFini
Self .IfDef:
(
Self .UserCode: cEmptyStr ()
Self .OutDocumentation
) // Self .IfDef:
; // OutIniOrFini
INTERFACE elem_func RegisterTestCaseMethod
(
'RegisterTestCase' MakeIniProcedure: (
IN aMade
aMade ->^ cUserCodePrefix ^:= [
' TestFramework.RegisterTest(' Self .TypeName '.Suite);'
]
) // MakeIniProcedure:
)
>>> Result
; // RegisterTestCaseMethod
INTERFACE elem_func RegisterTestClassMethod
(
'RegisterTestClass' MakeIniProcedure: (
IN aMade
aMade ->^ cUserCodePrefix ^:= [
' _RegisterPublicInformation5;' \n ' _RegisterPublicInformation6;'
]
) // MakeIniProcedure:
)
>>> Result
; // RegisterTestClassMethod
INTERFACE elem_func RegisterTagTableMethod
(
'RegisterTagTable' MakeIniProcedure: (
IN aMade
aMade ->^ cUserCodePrefix ^:= [
cSpace Self .TypeName '.SetAsDefault;'
]
) // MakeIniProcedure:
)
>>> Result
; // RegisterTagTableMethod
INTERFACE elem_func RegisterServiceImplementationMethod
(
'bind' MakeIniProcedure: (
IN aMade
aMade -> %SUM := ( 'Регистрация ' Self .TypeName Cat )
aMade .AddMethodWithParams: cUserCodePrefix Self .BindServiceImplementationUC
) // MakeIniProcedure:
)
>>> Result
; // RegisterServiceImplementationMethod
INTERFACE elem_func MakeIniStr
STRING IN aName
ModelElement IN aSpeller
STRING IN aPrefix
(
aName MakeIniProcedure: (
IN aMade
aMade -> %SUM := ( [ 'Инициализация ' aPrefix Self .Name ] strings:Cat )
aMade -> "ifdef" := ( Self .IfDefStr )
aMade -> "ifndef" := ( Self .IfNDefStr )
aMade .AddMethodWithParams: cUserCodePrefix ( Self aSpeller ) .InitStrUCPrim
) // MakeIniProcedure:
)
>>> Result
; // MakeIniStr
elem_iterator IniOperationsPrim
Self .OperationsEx
.filter> .IsIni
>>> Result
; // IniOperationsPrim
ModelElement elem_func ElementOrParentThatCanHaveIniOperations
RULES
( Self .IsClassOrMixIn )
Self
( Self .IsUtilityPack )
Self
( Self .Parent .IsNil )
nil
DEFAULT
( Self .Parent call.me )
; // RULES
>>> Result
; // ElementOrParentThatCanHaveIniOperations
INTERFACE elem_func RegTypeMethod
Cached:
(
VAR l_TypeName
Self .TypeName >>> l_TypeName
VAR l_Name
'Reg_Type_' l_TypeName Cat >>> l_Name
l_Name MakeIniProcedure: (
IN aMade
aMade -> "ifndef" := 'NoScripts'
aMade -> %SUM := ( 'Регистрация типа ' l_TypeName Cat )
aMade ->^ cUserCodePrefix ^:= [
' '
'TtfwTypeRegistrator.RegisterType('
Self .TypeInfo
');'
] // aMade ->^ cUserCodePrefix
) // MakeIniProcedure:
)
>>> Result
; // RegTypeMethod
elem_iterator IniOperations
VAR l_IniOperations
Self .IniOperationsPrim >>> l_IniOperations
l_IniOperations
RULES
( Self .IsConstants )
begin
VAR l_Speller
Self .Speller >>> l_Speller
RULES
( l_Speller .IsNotNil )
begin
VAR l_Parent
Self .ElementOrParentThatCanHaveIniOperations >>> l_Parent
VAR l_Prefix
Self .GetUP 'extprop:pas:ElementPrefix' >>> l_Prefix
Self .Attributes
.for>
(
IN aConst
VAR l_Name
[ 'Init_Str_' aConst .Name ] strings:Cat >>> l_Name
RULES
(
l_Parent call.me
.filter> ( .Name l_Name == )
.IsEmpty
)
(
.join> ToArray: ( aConst l_Name aConst .Speller l_Prefix .MakeIniStr )
)
; // RULES
) // .for>
end // ( l_Speller .IsNotNil )
; // RULES
end // ( Self .IsConstants )
(
( Self .IsTestCase )
AND ( Self .Abstraction at_abstract != )
AND ( Self .IsMixIn ! )
)
( .join> ToArray: ( Self .RegisterTestCaseMethod ) )
( Self .IsTestClass )
( .join> ToArray: ( Self .RegisterTestClassMethod ) )
( Self .IsTagTable )
( .join> ToArray: ( Self .RegisterTagTableMethod ) )
(
( Self .IsServiceImplementation )
AND ( l_IniOperations 'bind' .HasModelElementWithName ! )
)
( .join> ToArray: ( Self .RegisterServiceImplementationMethod ) )
( Self .IsClassOrMixIn )
(
VAR l_WasRegisterInEngine
false >>> l_WasRegisterInEngine
if ( Self .IsMixIn ! ) then
begin
if ( Self .Abstraction at_abstract != ) then
begin
if ( Self GarantModel::TtfwRegisterableWord .InheritsFromOrSomeAncestorImplements ) then
begin
true >>> l_WasRegisterInEngine
if ( l_IniOperations 'Ini_Reg' .HasModelElementWithName ! ) then
begin
.join> ToArray: (
'Ini_Reg' MakeIniProcedure: (
IN aMade
VAR l_TypeName
Self .TypeName >>> l_TypeName
aMade -> Parent := ( Self .WeakRef )
aMade -> "ifndef" := 'NoScripts'
aMade -> %SUM := ( 'Регистрация ' Self .Name Cat )
aMade ->^ cUserCodePrefix ^:= [ cSpace l_TypeName '.RegisterInEngine;' ]
) // MakeIniProcedure:
) // .join>
end // ( l_IniOperations GarantModel::l3UnknownPrim.ClearFields .HasModelElement )
end // ( l_IniOperations 'Ini_Reg' .HasModelElementWithName ! )
end // ( Self .Abstraction at_abstract != )
end // ( Self .IsMixIn ! )
if ( l_WasRegisterInEngine ! ) then
begin
if ( Self .NeedRegisterInScripts ) then
begin
if ( l_IniOperations 'Ini_Reg_Class' .HasModelElementWithName ! ) then
begin
.join> ToArray: (
'Ini_Reg_Class' MakeIniProcedure: (
IN aMade
VAR l_TypeName
Self .TypeName >>> l_TypeName
aMade -> Parent := ( Self .WeakRef )
aMade -> "ifndef" := 'NoScripts'
aMade -> %SUM := ( 'Регистрация ' Self .Name Cat )
aMade ->^ cUserCodePrefix ^:= [
if ( Self GarantModel::TtfwWord .InheritsFrom ) then
begin
' ' Self .TypeName '.RegisterClass;'
end
else
begin
' TtfwClassRef.Register(' Self .TypeName ');'
end
] // aMade ->^ cUserCodePrefix
) // MakeIniProcedure:
) // .join>
end // ( l_IniOperations 'Ini_Reg_Class' .HasModelElementWithName ! )
end // ( Self .NeedRegisterInScripts )
end // ( l_WasRegisterInEngine ! )
) // ( Self .IsClassOrMixIn )
( Self .IsEnum )
begin
if ( Self .NeedRegisterInScripts ) then
begin
.join> ToArray: ( Self .RegTypeMethod )
end // ( Self .NeedRegisterInScripts )
end // ( Self .IsEnum )
( Self .IsException )
begin
if ( Self .NeedRegisterInScripts ) then
begin
.join> ToArray: ( Self .RegTypeMethod )
end // ( Self .NeedRegisterInScripts )
end // ( Self .IsException )
( Self .IsInterface )
begin
if ( Self .NeedRegisterInScripts ) then
begin
.join> ToArray: ( Self .RegTypeMethod )
end // ( Self .NeedRegisterInScripts )
end // ( Self .IsInterface )
( Self .IsScriptKeywordsPack )
begin
Self .InheritsEx
.join> ( Self .ImplementsEx )
.join> (
Self .OperationsEx
.filter> .IsSomeKeyWord
.mapToTarget>
) // .join>
.joinWithLambded>
( Self .OperationsEx ) ( .Parameters .mapToTarget> )
.filter> .IsAcceptableForScripts
.map> .RegTypeMethod
.filter> ( .Name l_IniOperations SWAP .HasModelElementWithName ! )
.for> (
IN aMethod
.join> ToArray: aMethod
array:Copy >>> l_IniOperations
// - перекопируем массив, чтобы убрать дубликаты
l_IniOperations
// - кладём его обратно на стек
) // .for>
end // ( Self .IsScriptKeywordsPack )
; // RULES
>>> Result
; // IniOperations
elem_iterator FiniOperations
Self .OperationsEx
.filter> .IsFini
>>> Result
; // FiniOperations
ARRAY CompileTime-VAR g_DeferredInitialization nil
elem_proc OutIniFiniSection
: OutInitialization
if ( g_DeferredInitialization .IsNil ) then
begin
'initialization' .Out
end // ( g_DeferredInitialization .IsNil )
else
begin
g_DeferredInitialization .Out
nil >>> g_DeferredInitialization
end // ( g_DeferredInitialization .IsNil )
; // OutInitialization
VAR l_WasOut
false >>> l_WasOut
VAR l_WasInitialization
false >>> l_WasInitialization
Self .ForChildren> .All (
.IniOperations .for> (
if ( l_WasOut ! ) then
begin
true >>> l_WasOut
true >>> l_WasInitialization
OutInitialization
end // ( l_WasOut ! )
.OutIniOrFini
) // .IniOperations .for>
) // Self .ForChildren> .All
l_WasOut ? OutLn
false >>> l_WasOut
Self .ForChildren> .All (
.FiniOperations .for> (
if ( l_WasOut ! ) then
begin
true >>> l_WasOut
if ( l_WasInitialization ! ) then
begin
true >>> l_WasInitialization
OutInitialization
OutLn
end // ( l_WasInitialization ! )
'finalization' .Out
end // ( l_WasOut ! )
.OutIniOrFini
) // .FiniOperations .for>
) // Self .ForChildren> .All
l_WasOut ? OutLn
; // OutIniFiniSection
elem_proc OutImplementationSection
Self .OutDefinitionsSection: .IsForImplementation
VAR l_WasOut
false >>> l_WasOut
Self .ForChildren> .IsForImplementation (
.GlobalVars
.filter> ( .Visibility PrivateAccess != )
.for> ( .OutVar true >>> l_WasOut )
)
Self .ForChildren> .All (
.GlobalVars
.filter> ( .Visibility PrivateAccess == )
.for> ( .OutVar true >>> l_WasOut )
)
l_WasOut ? OutLn
Self .ForChildren> .All (
.ConstantsEx .filter> ( .ConstantsListVisibility PrivateAccess == ) .OutConstantsList
)
Self .ForChildren> .IsForImplementation (
IN anItem
VAR l_GlobalOperations
anItem .GlobalOperations >>> l_GlobalOperations
VAR l_GlobalOperationsForOverload
anItem .GlobalOperationsForOverload >>> l_GlobalOperationsForOverload
l_GlobalOperations
.for> .MethodInterfaceForEx: l_GlobalOperationsForOverload .MethodBody
)
TF g_EnableMethodDirectives (
false >>> g_EnableMethodDirectives
Self .ForChildren> .IsForInterface (
IN anItem
VAR l_GlobalOperations
anItem .GlobalOperations >>> l_GlobalOperations
VAR l_GlobalOperationsForOverload
anItem .GlobalOperationsForOverload >>> l_GlobalOperationsForOverload
l_GlobalOperations
.filter> ( .Visibility PrivateAccess == )
.for> .MethodInterfaceForEx: l_GlobalOperationsForOverload .MethodBody
l_GlobalOperations
.filter> ( .Visibility PrivateAccess != )
.for> .MethodInterfaceForEx: nil .MethodBody
)
) // TF g_EnableMethodDirectives
Self .ForChildren> .All .OutImplementation
Self .OutIniFiniSection
; // OutImplementationSection
STRING elem_func Defines
Self .GetUP "defines" >>> Result
if ( Result .IsNil ) then
begin
VAR l_Parent
Self .Parent >>> l_Parent
if ( l_Parent .IsNotNil ) then
begin
l_Parent call.me >>> Result
end // ( l_Parent .IsNotNil )
end // ( Result .IsNil )
else
begin
Self .PathOnly Result Cat >>> Result
end // ( Result .IsNil )
; // Defines
elem_proc OutUnitHeader
[ '// Модуль: "' Self .FinalFileName '"' ] .Out
[ '// Стереотип: "' Self .Stereotype .Name '"' ] .Out
if ( Self .Name .IsNotNil ) then
begin
[
'// Элемент модели: "' Self .Name '"'
if ( Self .UID .IsNotNil ) then
begin
' MUID: (' Self .UID ')'
end // ( Self .UID .IsNotNil )
] .Out
if ( Self .TypeName .IsNotNil ) then
begin
if ( Self .Name Self .TypeName ?!= ) then
begin
[ '// Имя типа: "' Self .TypeName '"' ] .Out
end // ( Self .Name Self .TypeName ?!= )
end // ( Self .TypeName .IsNotNil )
end // ( Self .Name .IsNotNil )
OutLn
; // OutUnitHeader
PROCEDURE DoOutUnit
^ IN aLambda
TF g_Implementor (
nil >>> g_Implementor
TF g_WasTypeOpener (
nil >>> g_WasTypeOpener
TF g_WasConst (
false >>> g_WasConst
TF g_WasForwarded (
false >>> g_WasForwarded
TF g_WasType (
DropWasType
TF g_MixInValues (
[] >>> g_MixInValues
TF g_OutedTypes (
[] >>> g_OutedTypes
TF g_ForwardedTypes (
[] >>> g_ForwardedTypes
aLambda DO
) // TF g_ForwardedTypes
) // TF g_OutedTypes
) // TF g_MixInValues
) // TF g_WasType
) // TF g_WasForwarded
) // TF g_WasConst
) // TF g_WasTypeOpener
) // TF g_Implementor
; // DoOutUnit
elem_proc OutApplicationBody
RULES
( Self .IsTestTarget )
begin
[
' {$IfDef nsTest}' \n
' g_CVSPath := '
cQuote
Self .FinalFileName sysutils:ExtractFilePath '\' .CutSuffix
cQuote ';' \n
' {$EndIf nsTest}'
] .Out
Indented: ( Self .UserCode: 'CVSPath' () )
RULES
( Self .UPisTrue "need UC in project" )
begin
Indented: ( Self .UserCode: 'manualcode' () )
end // ( Self .UPisTrue "need UC in project" )
( Self .IsVCMTestTarget )
begin
RULES
(
Self .DependsVCMGUI
.filter> ( .GetUP "F1Like" false ?== )
.IsEmpty
)
( ' TF1AutoTestSuite.Register;' .Out )
DEFAULT
( ' TAutoTestsSuite.Register;' .Out )
; // RULES
Self .DependsVCMGUI
.for> (
IN anItem
anItem call.me
) // .for>
end // ( Self .IsVCMTestTarget )
DEFAULT
begin
if ( Self .UPisTrue "no scripts" ! ) then
begin
' TAutoTestsSuite.Register;' .Out
end // ( Self .UPisTrue "no scripts" ! )
' try' .Out
[
' if KTestRunner.NeedKTestRunner(['
VAR l_WasComma
false >>> l_WasComma
Self .ChildrenEx
.filter> .IsTestResults
.map> .TypeName
.for> ( .WithComma: l_WasComma .KeepInStack )
']) then'
] .Out
' KTestRunner.RunRegisteredTests' .Out
' else' .Out
' if System.IsConsole then' .Out
' TextTestRunner.RunRegisteredTests' .Out
' else' .Out
' GUITestRunner.RunRegisteredTests;' .Out
' except' .Out
' on E: Exception do' .Out
' begin' .Out
' {$If defined(MTDORB) AND defined(NoKPageTool)}' .Out
' if TKBridge.Exists then' .Out
' TKBridge.Instance.Logout;' .Out
' {$IfEnd}' .Out
' l3System.Exception2Log(E);' .Out
' Halt(2);' .Out
' end;//Exception' .Out
' end;//try..except' .Out
' if (TestsExitCode <> 0) then' .Out
' Halt(TestsExitCode);' .Out
end // DEFAULT
; // RULES
end // ( Self .IsTestTarget )
( Self .IsVCMGUI )
begin
[
' ' 'StdRes.TdmStdRes.Run(str_' Self .Name 'Title' ',' ' '
cQuote Self .GetUP "HelpFile" '.chm' cQuote
');'
] .Out
end // ( Self .IsVCMGUI )
DEFAULT
begin
Indented: ( Self .UserCode: 'manualcode' () )
end // DEFAULT
; // RULES
; // OutApplicationBody
STRING elem_func ProjectUnitPath
Cached:
(
VAR l_Path
RULES
( Self IsString )
RULES
( Self GarantModel::StdRes .Name == )
( GarantModel::StdRes .Name '.pas' Cat )
DEFAULT
''
; // RULES
( Self .Name GarantModel::StdRes .Name == )
( GarantModel::StdRes .Name '.pas' Cat )
( Self .InTie )
// - тут надо брать путь для адаптера
(
VAR l_pasPath
Self .GetUP 'pas:Path' >>> l_pasPath
RULES
( l_pasPath .IsNil )
''
DEFAULT
( [ cRoot l_pasPath ] cPathSep strings:CatSep )
; // RULES
)
( Self .UnitName 'GblAdapter' == )
''
DEFAULT
( Self .FinalFileName )
; // RULES
>>> l_Path
if ( l_Path .IsNotNil ) then
begin
if ( l_Path 'NotFinished\Borland\Delphi\Rtl\Sys' string:Pos -1 != ) then
begin
'' >>> l_Path
end // ( l_Path 'NotFinished\Borland\Delphi\Rtl\Sys' string:Pos -1 != )
end // ( l_Path .IsNotNil )
if ( l_Path .IsNotNil ) then
begin
l_Path cNotFinished '' string:Replace >>> l_Path
l_Path cNotCompleted '' string:Replace >>> l_Path
l_Path 'NotFinished\' '' string:Replace >>> l_Path
end // ( l_Path .IsNotNil )
l_Path
)
>>> Result
; // ProjectUnitPath
STRING elem_func ProjectUnitName
Self .UnitName
VAR l_Path
Self .ProjectUnitPath >>> l_Path
if ( l_Path .IsNotNil ) then
begin
[ ' in ' cQuote l_Path cQuote ] strings:Cat Cat
end // ( l_Path .IsNotNil )
>>> Result
; // ProjectUnitName
elem_proc OutUnit
DoOutUnit (
TF g_DefaultInterfaceAncestor (
Self .ChildrenEx .filter> ( .UPisTrue "is default ancestor" ) .FirstElement >>> g_DefaultInterfaceAncestor
[
RULES
( Self .IsDLL )
'library'
( Self .IsExe )
'program'
DEFAULT
'unit'
; // RULES
cSpace
Self .UnitNamePrim ';'
] .Out
Self .OutDocumentation
OutLn
Self .OutUnitHeader
VAR l_Defines
Self .Defines >>> l_Defines
if ( l_Defines .IsNotNil ) then
begin
[ cOpenComment '$Include ' l_Defines cCloseComment ] .Out
OutLn
end // ( l_Defines .IsNotNil )
if ( Self .IsExe ) then
begin
if ( Self .UPisTrue "console" ) then
begin
'{$APPTYPE CONSOLE}' .Out
OutLn
end // ( Self .UPisTrue "console" )
end // ( Self .IsExe )
if ( Self .IsTarget ! ) then
begin
'interface' .Out
OutLn
end // ( Self .IsTarget ! )
ARRAY VAR l_Used
[] >>> l_Used
Self .IfDef: (
if ( Self .IsTarget ) then
begin
Self 'intf_uses' .OutUses: l_Used ( Self .ProjectUses ) .ProjectUnitName
end // ( Self .IsTarget )
else
begin
Self 'intf_uses' .OutUses: l_Used ( Self .IntfUses ) .UnitName
end // ( Self .IsTarget )
Self .OutInterfaceSection
if ( Self .IsElementProxy ) then
begin
Self .UserCode: 'intf_code' ()
OutLn
end // ( Self .IsElementProxy )
) // Self .IfDef:
if ( Self .IsTarget ! ) then
begin
'implementation' .Out
OutLn
end // ( Self .IsTarget ! )
Self .IfDef: (
if ( Self .IsTarget ! ) then
begin
Self 'impl_uses' .OutUses: l_Used ( Self .ImplUses ) .UnitName
end // ( Self .IsTarget ! )
RULES
( Self .IsTestClass )
(
Self .MainAncestor .IfDef:
(
Self .OutImplementationSection
) // Self .MainAncestor .IfDef:
) // ( Self .IsTestClass )
( Self .IsSimpleClass )
(
Self .MainAncestor .IfDef:
(
Self .OutImplementationSection
) // Self .MainAncestor .IfDef:
) // ( Self .IsSimpleClass )
DEFAULT
( Self .OutImplementationSection )
; // RULES
RULES
( Self .IsElementProxy )
(
Self .UserCode: 'impl_code' ()
OutLn
)
( Self .IsDLL )
(
'exports' .Out
Self .UserCode: 'exports' ( )
';' .Out
OutLn
)
; // RULES
) // Self .IfDef:
RULES
( Self .IsExe )
(
if ( Self .UPisTrue "console" ! ) then
begin
[ '{$R ' Self .UnitName '.res' '}' ] .Out
if ( Self .UPisTrue "needs second icon" ) then
begin
[ '{$R main_icon2.res}' ' // вторая иконка приложения' ] .Out
end // ( Self .UPisTrue "needs second icon" )
OutLn
end // ( Self .UPisTrue "console" ! )
if ( Self .UPisTrue "need UC in project" ) then
begin
Self .UserCode: 'manualres' ()
OutLn
end // ( Self .UPisTrue "need UC in project" )
'begin' .Out
Self .OutApplicationBody
) // ( Self .IsExe )
( Self .IsDLL )
(
[ '{$R ' Self .UnitName '.res' '}' ] .Out
OutLn
'begin' .Out
) // ( Self .IsDLL )
; // RULES
'end.' .Out
) // TF g_DefaultInterfaceAncestor
) // DoOutUnit
; // OutUnit
STRING elem_func DefineName
Cached:
(
Self .UnitName cDot cUnderline string:Replace
)
>>> Result
; // DefineName
elem_proc OutMixIn
DoOutUnit (
VAR l_DefineName
Self .DefineName >>> l_DefineName
[ cOpenComment '$IfNDef ' l_DefineName cCloseComment \n ] .Out
Self .OutUnitHeader
[ cOpenComment '$Define ' l_DefineName cCloseComment \n ] .Out
Self .IfDefElse:
(
Self .OutInterfaceSection
)
(
VAR l_Parent
Self .CalcParentAndInclude >>> l_Parent
[ Self .TypeName ' = ' l_Parent .TypeName ';' \n ] .Out
)
// Self .IfDefElse:
[ cOpenComment '$Else ' l_DefineName cCloseComment \n ] .Out
VAR l_DefineNameImpl
[ l_DefineName '_impl' ] >>> l_DefineNameImpl
[ cOpenComment '$IfNDef ' l_DefineNameImpl cCloseComment \n ] .Out
[ cOpenComment '$Define ' l_DefineNameImpl cCloseComment \n ] .Out
TF g_DeferredInitialization (
[ cOpenComment '$Else ' l_DefineNameImpl cCloseComment \n ] >>> g_DeferredInitialization
Self .IfDef: (
Self .OutImplementationSection
) // Self .IfDef:
)
[ cOpenComment '$EndIf ' l_DefineNameImpl cCloseComment \n ] .Out
[ cOpenComment '$EndIf ' l_DefineName cCloseComment \n ] .Out
) // DoOutUnit
; // OutMixIn
STRING elem_func PasFinalFileName
Self .GetUP 'intf.pas:Path' >>> Result
if ( Result .IsNil ) then
begin
RULES
( Self .IsTestLibrary )
begin
Self .PasPathOnly >>> Result
if ( Result .IsNotNil ) then
begin
[
Result
[ Self .Name cSpace cUnderline string:Replace '_TestLibrary' '.pas' ] strings:Cat
] cPathSep strings:CatSep >>> Result
end // ( Result .IsNotNil )
end // ( Self .IsTestLibrary )
( Self .IsTestUnit )
begin
Self .PasPathOnly >>> Result
if ( Result .IsNotNil ) then
begin
[ Result
[
[ Self .Parent .Name cUnderline Self .Name ] strings:Cat
cSpace cUnderline string:Replace
cDot cUnderline string:Replace
'_TestUnit' '.pas'
] strings:Cat
] cPathSep strings:CatSep >>> Result
end // ( Result .IsNotNil )
end // ( Self .IsTestUnit )
( Self .IsElementProxy )
begin
Self .PasPathOnly >>> Result
if ( Result .IsNotNil ) then
begin
[
Result
[ Self .Name cProxy '.pas' ] strings:Cat
] cPathSep strings:CatSep >>> Result
end // ( Result .IsNotNil )
end // ( Self .IsElementProxy )
( Self .IsScriptKeywordsPack )
begin
Self .PasPathOnly >>> Result
if ( Result .IsNotNil ) then
begin
[
Result
[ Self .Name '.pas' ] strings:Cat
] cPathSep strings:CatSep >>> Result
end // ( Result .IsNotNil )
end // ( Self .IsScriptKeywordsPack )
; // RULES
end // ( Result .IsNil )
; // PasFinalFileName
elem_generator pas
CONST Ext '.pas'
BOOLEAN elem_func CanCopyToFinalFile
RULES
( Self .UseNewGen )
true
DEFAULT
false
; // RULES
>>> Result
; // CanCopyToFinalFile
STRING elem_func FinalFileNamePrim
Self .PasFinalFileName >>> Result
; // FinalFileNamePrim
RULES
( Self .IsMixIn )
( Self .OutMixIn )
( Self .IsUserType )
( Self .OutUnit )
( Self .IsInterfaces )
( Self .OutUnit )
( Self .IsEvdSchemaElement )
( Self .OutUnit )
( Self .IsSimpleClass )
( Self .OutUnit )
( Self .IsElementProxy )
( Self .OutUnit )
( Self .IsUtilityPack )
( Self .OutUnit )
( Self .IsTestClass )
( Self .OutUnit )
( Self .IsTarget )
( Self .OutUnit )
( Self .IsTagTable )
( Self .OutUnit )
( Self .IsTestLibrary )
( Self .OutUnit )
( Self .IsTestUnit )
( Self .OutUnit )
DEFAULT
( Self .Name .Out )
; // RULES
; // pas
elem_generator pas_dependent
Inherits .pas
STRING elem_func FinalFileNamePrim
Self .PasFinalFileName >>> Result
if ( Result .IsNotNil ) then
begin
Result .? Ext sysutils:ChangeFileExt >>> Result
end // ( Result .IsNotNil )
; // FinalFileNamePrim
; // pas_dependent
STRING elem_func AttrName
RULES
( Self .IsOverride )
( Self .MainAncestor call.me )
DEFAULT
( Self .Name )
; // RULES
>>> Result
; // AttrName
ModelElement elem_func AttrType
RULES
//( Self .IsOverride )
// ( Self .MainAncestor call.me )
DEFAULT
( Self .MethodType )
; // RULES
>>> Result
; // AttrType
ARRAY CompileTime-VAR g_FormControls nil
elem_proc ToDFM
// <%C#f_ToDFM()>\
// <%G#f_ToDFM()>\
// <%R#f_ToDFM()>
// [{%S%f_NeedPutToDFM()=true}\
// [{%f_exists_in_list(FORM_CONTROLS,"%S%f_pas_AttrName()")=false}\
// %f_add_to_list(FORM_CONTROLS,"%S%f_pas_AttrName()")\
// \n# object %S%f_pas_AttrName(): %S%f_pas_ResultTypeName()\
// [{"%SD"!=""&%S{need Caption}!=false}\n# Caption = '%SD']\
// <%C#f_ToDFM()>\
// [{%S%f_IsOverride()=true}\
// <{}{}{r}%g<%C#f_ToDFM()>>\
// ]
// # end\
// ]\
// ]
RULES
( Self .IsVCMCustomForm )
(
Self .Attributes .for> call.me
Self .InheritsEx .for> call.me
Self .ImplementsEx .for> call.me
)
( Self .IsControlPrim )
(
if ( Self .NeedPutToDFM ) then
begin
if ( Self .AttrName .TextNotInArray: g_FormControls ) then
begin
Self .AttrName .AddToArray: g_FormControls
Indented: (
[ ' object ' Self .AttrName ': ' Self .AttrType .TypeName ] .Out
Self .Attributes .for> call.me
if ( Self .IsOverride ) then
begin
Self .InheritsEx .for> ( .Attributes .for> call.me )
end // ( Self .IsOverride )
[ ' end' ] .Out
) // Indented:
end // ( Self .AttrName .TextNotInArray: g_FormControls )
end // ( Self .NeedPutToDFM )
)
; // RULES
; // ToDFM
elem_proc BeforeDFMControls
RULES
( Self .IsVCMForm )
(
[ ' Caption = ' cQuote Self .Documentation cQuote ] .Out
[ ' Color = $00F9F8FA' ] .Out
VAR l_ZoneType
Self .GetUP "ZoneType" >>> l_ZoneType
if ( l_ZoneType .IsNotNil ) then
if ( l_ZoneType 'Any' != ) then
begin
[ ' ZoneType = vcm_zt' l_ZoneType ] .Out
end // ( l_ZoneType 'Any' != )
[ ' PixelsPerInch = 96' ] .Out
[ ' TextHeight = 13' ] .Out
[ ' object Entities: TvcmEntities' ] .Out
[ ' Left = 24' ] .Out
[ ' Top = 24' ] .Out
[ ' end' ] .Out
)
; // RULES
; // BeforeDFMControls
elem_generator dfm
Inherits .pas_dependent
CONST Ext '.dfm'
BOOLEAN elem_func NeedOwnFilePrim
Self .IsVCMCustomForm
AND ( Self .Abstraction at_final == )
>>> Result
; // NeedOwnFilePrim
BOOLEAN elem_func CanCopyToFinalFile
Self .GetUP "finished dfm" false ?!= >>> Result
; // CanCopyToFinalFile
TF g_FormControls (
[] >>> g_FormControls
[ 'object ' Self .TypeName .CutT ': ' Self .TypeName ] .Out
[ ' Left = 204' ] .Out
[ ' Top = 118' ] .Out
[ ' Width = 320' ] .Out
[ ' Height = 240' ] .Out
Self .BeforeDFMControls
Self .ToDFM
[ 'end' ] .Out
) // TF g_FormControls
; // dfm
elem_generator res.cmd
Inherits .pas_dependent
CONST Ext '.res.cmd'
BOOLEAN elem_func NeedOwnFilePrim
Self .NeedsScript >>> Result
; // NeedOwnFilePrim
BOOLEAN elem_func CanCopyToFinalFile
true >>> Result
; // CanCopyToFinalFile
VAR l_Name
WithGen: .pas ( Self .EffectiveUnitName >>> l_Name )
[ 'MakeCo ' l_Name '.rc.script' ] .Out
[ 'brcc32 ' l_Name '.rc' ] .Out
//call.inherited
; // res.cmd
BOOLEAN elem_func NeedsWordsAliases
Cached:
(
RULES
( Self .IsScriptKeywordsPack ! )
false
( Self .UPisTrue "no class name" )
true
( Self .UPisTrue "no_pop" )
true
DEFAULT
false
; // RULES
)
>>> Result
; // NeedsWordsAliases
elem_generator rc.script
Inherits .res.cmd
CONST Ext '.rc.script'
BOOLEAN elem_func CanCopyToFinalFile
/*{
RULES
( Self .NeedsWordsAliases ! )
true
DEFAULT
false
; // RULES
}*/
true >>> Result
; // CanCopyToFinalFile
Self .OutUnitHeader
VAR l_WasManUses
false >>> l_WasManUses
: OutManUses
l_WasManUses ! ? (
true >>> l_WasManUses
OutLn
Self .UserCode: 'man_uses' ()
OutLn
) // l_WasManUses ! ?
; // OutManUses
Self .NeedsWordsAliases ?
OutManUses
: OutScriptFrameWorkAliases
: OutWordAlias
IN aG
if (
( Self .UPisTrue "no class name" ! )
AND ( aG .SelfName 'SV' != )
) then
begin
'USES' .Out
[ cSpace 'axiom:' aG .SelfName ] .Out
';' .Out
OutLn
end // ( Self .UPisTrue "no class name" ! )
[ '// Класс ' aG .Name ' - ' aG .SelfName ] .Out
Self .OperationsEx
.filter> .IsKeyWord
.for> (
IN anOp
VAR l_NameForScript
anOp .NameForScript >>> l_NameForScript
[
'// Операция ' anOp .Name
if ( l_NameForScript .IsNotNil ) then
begin
' - ' l_NameForScript
end // ( l_NameForScript .IsNotNil )
] .Out
if ( anOp .Speller .NotIsNil ) then
begin
anOp .Speller .NameForScript >>> l_NameForScript
[
'// Класс реализующий операцию '
anOp .Speller .Name
' - '
l_NameForScript
] .Out
if ( anOp .IsCreator ! ) then
begin
VAR l_CanonicName
[
'pop:'
aG .SelfName
':'
anOp .Name
'pop_' .CutPrefix
[ aG .SelfName string:Lower cUnderline ] strings:Cat .CutPrefix
cUnderline ':' string:Replace
] strings:Cat >>> l_CanonicName
if ( l_CanonicName l_NameForScript != ) then
begin
[ 'WordAlias ' l_CanonicName cSpace l_NameForScript ] .Out
end // ( l_CanonicName l_NameForScript != )
end // ( anOp .IsCreator ! )
end // ( anOp .Speller .NotIsNil )
) // Self .OperationsEx
OutLn
; // OutWordAlias
if ( Self .NeedsWordsAliases ) then
begin
Self .InheritsEx
.join> ( Self .ImplementsEx )
.filter> .IsAcceptableForScripts
//.filter> ( DROP Self .NeedsWordsAliases /* Тут надо ещё проверку на SV */ )
.for> OutWordAlias
end // ( Self .NeedsWordsAliases )
; // OutScriptFrameWorkAliases
Self .IsScriptKeywordsPack ?
OutScriptFrameWorkAliases
Self .UserCode: 'impl' ()
OutLn
'EXPORTS' .Out
Self .UserCode: 'exports' ( ' *' )
OutLn
; // rc.script
elem_generator rc
Inherits .res.cmd
CONST Ext '.rc'
Self .OutUnitHeader
VAR l_Name
WithGen: .pas ( Self .EffectiveUnitName >>> l_Name )
[ l_Name ' RCDATA LOADONCALL MOVEABLE DISCARDABLE ' l_Name '.rc.script.co' ] .Out
//call.inherited
; // rc
ARRAY CompileTime-VAR g_GeneratedElements []
%REMARK 'Ранее сгенерированные элементы'
elem_proc GenerateWithChildren
Sequence IN aGenerators
if ( Self .NotInArray: g_GeneratedElements ) then
begin
Self .AddToArray: g_GeneratedElements
aGenerators CodeIterator .for> (
// - цикл по генераторам для Self
TtfwWord IN aGenerator
TF g_CurrentGenerator (
aGenerator >>> g_CurrentGenerator
if ( Self .NeedOwnFile ) then
begin
VAR l_Name
Self .Name >>> l_Name
[ l_Name ' ' g_CurrentGenerator .WordName ] strings:Cat >>> l_Name
Log: [ l_Name ' generation start' ]
VAR l_Time
StartTimer
TRY
( Self .GenerateWordToFileWith: .CurrentGenerator )
FINALLY
l_Name StopTimerNoLog >>> l_Time
END // TRY..FINALLY
l_Time 1000 DIV >>> l_Time
if ( l_Time > 3 ) then
begin
Log: [ l_Name ' generation end ' l_Time ' seconds' ]
end // ( l_Time > 3 )
end // ( Self .NeedOwnFile )
else
( Self .DeleteWordFile )
) // TF g_CurrentGenerator
) // aGenerators CodeIterator .for>
Self .ChildrenEx .for> ( aGenerators call.me )
// - тут генерируем детей
end // Self .NotInArray: g_GeneratedElements
; // GenerateWithChildren
elem_proc call.generators.in.list
Sequence ^ IN aGenerators
Self aGenerators .GenerateWithChildren
; // call.generators.in.list
elem_proc Generate
g_GeneratedFiles .IsNil ?FAIL 'Массив g_GeneratedFiles не инициализирован'
g_GeneratedElements .IsNil ?FAIL 'Массив g_GeneratedElements не инициализирован'
Self .call.generators.in.list ( .pas .res.cmd .rc .rc.script .dfm )
; // Generate
пятница, 20 мая 2016 г.
#1244. Кодогенерация. Только код
Подписаться на:
Комментарии к сообщению (Atom)
Комментариев нет:
Отправить комментарий