Предыдущая серия была тут - Эмуляция объектов. Продолжаем.
Код примера:
Как всё это устроено "под капотом":
Ссылки на код:
Object.ms.dict.web
Point96.ms.script.web
Код примера:
USES macro.ms.dict core.ms.dict NoCapsLock.ms.dict params.ms.dict integer.ms.dict Object.ms.dict Testing.ms.dict ; Test&Dump PointTest @ _:Object DumpElement INTEGER type Pixel // - пиксель List type PixelList // - список пикселей class Point Pixel member X Pixel member Y members-end constructor : Pixel right aX Pixel right aY new[ aX aY ] =: Result ; // : constructor 0 Point:: 0 0 =: Result ; // 0 constructor XY PixelList right aPoint array var Points [ aPoint ] =: Points Point:: ( Points FieldByOffset 0 ) ( Points FieldByOffset 1 ) =: Result ; // XY Pixel readonly X read X Pixel readonly Y read Y constructor OF Point right aPoint Point:: ( aPoint Point:X ) ( aPoint Point:Y ) =: Result ; // OF Point method + Point right aPoint Point:: ( Self Point:X (+) ( aPoint Point:X ) ) ( Self Point:Y (+) ( aPoint Point:Y ) ) =: Result ; // + Point method Neg Point:: Neg ( Self Point:X ) Neg ( Self Point:Y ) =: Result ; // Neg Point method - Point right aPoint Point:OF ( Self Point:+ ( aPoint Point:Neg ) ) =: Result ; // - OVERRIDE STRING method ToPrintable [ '( ' 'X: ' Self Point:X ToPrintable ', Y: ' Self Point:Y ToPrintable ' )' ] strings:Cat =: Result ; // ToPrintable void method Print Self Point:ToPrintable Print ; // Print class-end // Point class Rectangle Point member TopLeft Point member BottomRight members-end Point readonly TopLeft read TopLeft Point readonly BottomRight read BottomRight constructor : Point right aTopLeft Point right aBottomRight new[ aTopLeft aBottomRight ] =: Result ; // : OVERRIDE STRING method ToPrintable [ '( ' 'TopLeft: ' Self Rectangle:TopLeft Point:ToPrintable ', BottomRight: ' Self Rectangle:BottomRight Point:ToPrintable ' )' ] strings:Cat =: Result ; // ToPrintable void method Print Self Rectangle:ToPrintable Print ; // Print class-end // Rectangle Point var P1 Point var P2 Point var P3 Point var P4 Point var P5 Point var P6 Point var P7 Point var P8 Point var P9 Point var P10 Point var P11 P1 := Point:0 P2 := Point:0 P3 := Point:: 1 1 P4 := Point:XY ( 2 2 ) P5 := Point:OF P4 P6 := ( P3 Point:+ P4 ) P7 := ( P3 Point:- P4 ) P8 := ( P4 Point:- P3 ) P9 := ( P4 Point:Neg ) P10 := ( P3 Point:Neg ) P11 := Point:XY ( -2 2 ) Object var O1 O1 := P1 O1 Point:Print array var l_Points [ P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 P11 ] =: l_Points l_Points ==> Point:Print l_Points ==> ( Point:X Print ) l_Points ==> ( Point:Y Print ) l_Points ==> ( Point:class Print ) l_Points ==> ( Point:ClassName Print ) for l_Points ( for ( Object:class %G ) ( getClassName Print ) ) Rectangle var R1 Rectangle var R2 R1 := Rectangle:: P1 P4 R2 := Rectangle:: P6 P7 array var l_Rectangles [ R1 R2 ] =: l_Rectangles l_Rectangles ==> Rectangle:Print l_Rectangles ==> ( Rectangle:class Print ) l_Rectangles ==> ( Rectangle:ClassName Print ) for l_Rectangles ( for ( Object:class %G ) ( getClassName Print ) ) 'Hello ' (+) 'world' Print 'Hello ' (+) 'world' Print 'Hello ' (+) 'world' Print 1 (+) 2 Print 10 (+) 20 Print 0 (-) 10 Print Neg 10 Print Neg -10 Print ; // PointTest PointTest
Как всё это устроено "под капотом":
UNIT Object.ms.dict
USES
core.ms.dict
macro.ms.dict
NoCapsLock.ms.dict
implementation.ms.dict
params.ms.dict
axiom_push.ms.dict
Documentation.ms.dict
WordsRTTI.ms.dict
arrays.ms.dict
Debug.ms.dict
;
EXPORTS
implementation.ms.dict
USES
InheritsAndImplementsNew.ms.dict
;
EXPORTS
InheritsAndImplementsNew.ms.dict
// Понятное дело, что всю обвязку потом упрячем в отдельный словарь object.ms.dict
NamedWordProducer %FIELDS %Fld
NamedWordProducer %PROPERTIES %Props
NamedWordProducer %METHODS %Methods
NamedWordProducer %CONSTRUCTORS %Constructors
OBJECT FUNCTION DoMember
OBJECT IN aMember
aMember DO =: Result
; // DoMember
BOOLEAN FUNCTION FilterMember
OBJECT IN aMember
Result := ( aMember NotValid ! )
; // FilterMember
WordAlias %R .Implemented.Words
WordAlias %G .Inherited.Words
ARRAY FUNCTION %ClassRTTIList
IN %S
Literal IN aName
VAR l_List
%S %% ( aName |N ) =: l_List
if ( l_List NotValid ) then
( Result := [ ] )
else
( Result := ( l_List CodeIterator ) )
; // %ClassRTTIList
ARRAY FUNCTION %Fld
IN %S
%SUMMARY 'Возвращает итератор полей класса' ;
%S %ClassRTTIList %Fld >>> Result
; // %Fld
ARRAY FUNCTION %Props
IN %S
%SUMMARY 'Возвращает итератор свойств класса' ;
%S %ClassRTTIList %Props >>> Result
; // %Props
ARRAY FUNCTION %Methods
IN %S
%SUMMARY 'Возвращает итератор методов класса' ;
%S %ClassRTTIList %Methods >>> Result
; // %Methods
ARRAY FUNCTION %Constructors
IN %S
%SUMMARY 'Возвращает итератор конструкторов класса' ;
%S %ClassRTTIList %Constructors >>> Result
; // %Constructors
VOID OPERATOR class_impl
// - имплементация класса, пока "фиктивная"
// Тут мы будем хранить всю информацию о классе - предки, поля, методы
; // class_impl
//MACRO class_impl
//// - имплементация класса, пока "фиктивная"
// Literal IN aName
// @SELF Ctx:SetWordProducerForCompiledClass
// axiom:PushSymbol :
// aName |N Ctx:Parser:PushSymbol
// // axiom:PushSymbol ;
//; // class_imp
STRING var g_CurrentClass
( g_CurrentClass := '' )
STRING var g_CurrentClassImpl
( g_CurrentClassImpl := '' )
PRIVATE STRING operator MakeFieldOffsetName
STRING IN aName
[ 'c:' g_CurrentClass ':Offset:' aName ] strings:Cat =: Result
; // MakeFieldOffsetName
VOID operator define_member
STRING IN aName
INTEGER IN aOffset
axiom:PushSymbol private
axiom:PushSymbol Const
aName MakeFieldOffsetName Ctx:Parser:PushSymbol
aOffset Ctx:Parser:PushInt
; // define_member
INTEGER VAR g_ClassFieldOffset
[EXECUTE]
( g_ClassFieldOffset := 0 )
( g_ClassFieldOffset := 0 )
ARRAY VAR g_CurrentClassMembers
[EXECUTE]
( g_CurrentClassMembers := [ ] )
( g_CurrentClassMembers := [ ] )
ARRAY VAR g_CurrentClassProperties
[EXECUTE]
( g_CurrentClassProperties := [ ] )
( g_CurrentClassProperties := [ ] )
ARRAY VAR g_CurrentClassMethods
[EXECUTE]
( g_CurrentClassMethods := [ ] )
( g_CurrentClassMethods := [ ] )
ARRAY VAR g_CurrentClassConstructors
[EXECUTE]
( g_CurrentClassConstructors := [ ] )
( g_CurrentClassConstructors := [ ] )
MACRO member
Literal IN aName
Ctx:ClearTypeInfo
aName |N g_ClassFieldOffset define_member
Inc g_ClassFieldOffset
aName |N array:AddTo g_CurrentClassMembers
; // member
PRIVATE STRING operator MakeMethodSignaturePrim
STRING IN aClass
STRING IN aName
[ aClass ':' aName ] strings:Cat >>> Result
; // MakeMethodSignaturePrim
CONST cClassImplPrefix '_:'
STRING : getClassNamePrim
STRING IN Self
Self ':' string:Split =: Result DROP
; // getClassNamePrim
STRING : getClassName
IN Self
Self |N getClassNamePrim =: Result
; // getClassName
MACRO classExpander
^ IN anImpl
%SUMMARY 'Тут можно копировать поля и методы' ;
anImpl |@ %G .for> (
IN anItem
anItem %Fld .for> (
IN aField
axiom:PushSymbol member
aField |N Ctx:Parser:PushSymbol
) // anItem %Fld .for>
anItem %Props .for> (
IN aProp
axiom:PushSymbol WordAlias
g_CurrentClass aProp |N MakeMethodSignaturePrim Ctx:Parser:PushSymbol
anItem |N getClassNamePrim aProp |N MakeMethodSignaturePrim Ctx:Parser:PushSymbol
) // anItem %Props .for>
anItem %Methods .for> (
IN aProp
axiom:PushSymbol WordAlias
g_CurrentClass aProp |N MakeMethodSignaturePrim Ctx:Parser:PushSymbol
anItem |N getClassNamePrim aProp |N MakeMethodSignaturePrim Ctx:Parser:PushSymbol
) // anItem %Methods .for>
anItem %Constructors .for> (
IN aProp
axiom:PushSymbol WordAlias
g_CurrentClass aProp |N MakeMethodSignaturePrim Ctx:Parser:PushSymbol
anItem |N getClassNamePrim aProp |N MakeMethodSignaturePrim Ctx:Parser:PushSymbol
) // anItem %Constructors .for>
)
; // classExpander
CONST cObjectName 'Object'
MACRO class
Literal IN aName
g_CurrentClassMembers := [ ]
g_CurrentClassProperties := [ ]
g_CurrentClassMethods := [ ]
g_CurrentClassConstructors := [ ]
g_ClassFieldOffset := 0
aName |N =: g_CurrentClass
// axiom:PushSymbol class_impl
// - вообще должно быть так, почему не работает - надо разбираться
[
':'
@ class_impl Ctx:SetWordProducerForCompiledClass
[ cClassImplPrefix g_CurrentClass ] strings:Cat =: g_CurrentClassImpl
g_CurrentClassImpl
if ( g_CurrentClass !== cObjectName ) then
begin
'%INHERITS'
'@'
[ cClassImplPrefix cObjectName ] strings:Cat
';'
end
';'
] Ctx:Parser:PushArray
[
'array'
'type'
g_CurrentClass
] Ctx:Parser:PushArray
axiom:PushSymbol classExpander
g_CurrentClassImpl Ctx:Parser:PushSymbol
; // class
STRING FUNCTION NameAsString
STRING IN aName
%SUMMARY 'Делает имя таким, чтобы оно было как для Ctx:Parser:PushString';
[ '`' aName '`' ] strings:Cat >>> Result
; // NameAsString
: ListToNameAsString
STRING IN aName
ARRAY IN aList
aName
aList .for> NameAsString
';'
; // ListToNameAsString
MACRO RunCompileProps&Methods
[
'implementation'
g_CurrentClassImpl
'%PROPERTIES' g_CurrentClassProperties ListToNameAsString
'%METHODS' g_CurrentClassMethods ListToNameAsString
'%CONSTRUCTORS' g_CurrentClassConstructors ListToNameAsString
'end.'
] Ctx:Parser:PushArray
; // RunCompileProps&Methods
MACRO class-end
axiom:PushSymbol RunCompileProps&Methods
; // class-end
INTEGER type FieldOffset
// - смещение поля
PRIVATE VOID operator MakeMethodSignature
STRING IN aName
STRING VAR l_Signature
g_CurrentClass aName MakeMethodSignaturePrim >>> l_Signature
if ( l_Signature IsWordDeclared ) then
begin
axiom:PushSymbol REDEFINITION
end
axiom:PushSymbol :
l_Signature Ctx:Parser:PushSymbol
; // MakeMethodSignature
MACRO constructor
// - конструктор объектов, пока "фиктивный"
Literal IN aName
@SELF Ctx:SetWordProducerForCompiledClass
g_CurrentClass Ctx:Parser:PushSymbol
aName |N MakeMethodSignature
aName |N array:AddTo g_CurrentClassConstructors
; // constructor
PRIVATE VOID operator MakeSelfParam
g_CurrentClass Ctx:Parser:PushSymbol
axiom:PushSymbol in
'Self' Ctx:Parser:PushSymbol
; // MakeSelfParam
MACRO method
// - метод объекта, пока "фиктивный"
Literal IN aName
@SELF Ctx:SetWordProducerForCompiledClass
aName |N MakeMethodSignature
MakeSelfParam
aName |N array:AddTo g_CurrentClassMethods
; // method
MACRO readonly
// - read-only свойство объекта, пока "фиктивное"
Literal IN aName
@SELF Ctx:SetWordProducerForCompiledClass
aName |N MakeMethodSignature
MakeSelfParam
aName |N array:AddTo g_CurrentClassProperties
; // readonly
MACRO new[
axiom:PushSymbol [
axiom:PushSymbol @
g_CurrentClassImpl Ctx:Parser:PushSymbol
; // new[
MACRO RunCompileFields
[
'implementation'
g_CurrentClassImpl
'%FIELDS' g_CurrentClassMembers ListToNameAsString
'end.'
] Ctx:Parser:PushArray
; // RunCompileFields
MACRO members-end
axiom:PushSymbol private
axiom:PushSymbol Const
[ 'c:' g_CurrentClass ':Instance:Size' ] strings:Cat Ctx:Parser:PushSymbol
g_ClassFieldOffset Ctx:Parser:PushInt
axiom:PushSymbol RunCompileFields
; // members-end
class Object
: FieldByOffset
Object in Self
FieldOffset right anOffset
anOffset Self [i]
; // FieldByOffset
VIRTUAL STRING method ToPrintable
Self ToPrintable =: Result
; // ToPrintable
PRIVATE operator do-get-member
STRING IN aName
axiom:PushSymbol FieldByOffset
aName MakeFieldOffsetName Ctx:Parser:PushSymbol
; // do-get-member
MACRO get-member
Literal IN aName
aName |N do-get-member
; // get-member
MACRO read
Literal IN aName
'Self' Ctx:Parser:PushSymbol
aName |N do-get-member
axiom:PushSymbol =:
'Result' Ctx:Parser:PushSymbol
axiom:PushSymbol ;
; // read
INTEGER member VMT
members-end
TtfwWord readonly class read VMT
STRING readonly ClassName
Self Object:class getClassName =: Result
; // Object:ClassName
constructor DoNotCall
new[ ] =: Result
; // DoNotCall
class-end // Object
Ссылки на код:
Object.ms.dict.web
Point96.ms.script.web
