#1168. Эмуляция объектов на скриптах. Продолжаем. Только код

Предыдущая серия была тут - Эмуляция объектов. Продолжаем.

Код примера:

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