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

USES
 axiom:CompiledWordWorkerWord
 axiom:Finder
 axiom:Compiler
 macro.ms.dict
 NoCapsLock.ms.dict
 params.ms.dict
 integer.ms.dict
;

Test PointTest

// Понятное дело, что всю обвязку потом упрячем в отдельный словарь object.ms.dict

 IMMEDIATE operator implementation
   ^ LINK IN aWordToWork
  Ctx:PushCompiler
  Ctx:PushFinder
  OBJECT VAR l_NewCompiler
  aWordToWork |^@ =: l_NewCompiler
  
  if ( l_NewCompiler Is class::TkwCompiledWordWorkerWord ) then
  begin
   l_NewCompiler pop:CompiledWordWorkerWord:Compiled =: l_NewCompiler
  end
  
  l_NewCompiler pop:Compiler:SetToCtx
  l_NewCompiler pop:Finder:SetToCtx
 ; // implementation
 
 IMMEDIATE operator end.
  pop:Finder:SetToCtx
  pop:Compiler:SetToCtx
 ; // end.

NamedWordProducer %FIELDS %Fld

OBJECT FUNCTION DoMember 
 OBJECT IN aMember
 aMember DO =: Result
; // DoMember

BOOLEAN FUNCTION FilterMember 
 OBJECT IN aMember
 Result := ( aMember NotValid ! )
; // FilterMember
 
ARRAY FUNCTION ELEMLIST STRING IN aListName IN %S
 if ( %S NotValid ) then
  ( Result := [ ] )
 else
  (
   VAR l_List
   l_List := ( %S %% aListName )
   
   if ( l_List NotValid ) then
    ( Result := [ ] )
   else 
//    ( Result := ( [ l_List DO ] ) )
    ( Result := ( @ FilterMember ( @ DoMember ( l_List CodeIterator ) MAP ) FILTER ) ) 
  )
; // ELEMLIST

ARRAY FUNCTION %R 
 IN %S
 Result := ( '%R' %S ELEMLIST )
;

ARRAY FUNCTION %G 
 IN %S
 Result := ( '%G' %S ELEMLIST )
;

ARRAY FUNCTION %Fld 
 IN %S
 //Result := ( '%Fld' %S ELEMLIST )
 VAR l_List
 %S %% '%Fld' =: l_List
 if ( l_List NotValid ) then
  ( Result := [ ] )
 else 
  ( Result := ( l_List CodeIterator ) )
;

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 := [ ] )

MACRO member
 Literal IN aName
 Ctx:ClearTypeInfo
 aName |N g_ClassFieldOffset define_member
 Inc g_ClassFieldOffset
 aName |N array:AddTo g_CurrentClassMembers
; // member

MACRO classExpander
 ^ IN anImpl
 // Тут можно копировать поля и методы
 for ( ( anImpl |@ ) %G ) ( 
  IN anItem 
  for ( anItem %Fld ) ( 
   IN anItem 
   axiom:PushSymbol member
   anItem |N Ctx:Parser:PushSymbol
  ) 
 )
; // classExpander

CONST cObjectName 'Object'

MACRO class
 Literal IN aName
 g_CurrentClassMembers := [ ]
 g_ClassFieldOffset := 0
 aName |N =: g_CurrentClass
 // axiom:PushSymbol class_impl
 // - вообще должно быть так, почему не работает - надо разбираться
 [
  ':' 

  @ class_impl Ctx:SetWordProducerForCompiledClass
  [ '_:' g_CurrentClass ] strings:Cat =: g_CurrentClassImpl

  g_CurrentClassImpl
   if ( g_CurrentClass !== cObjectName ) then
   begin
    '%INHERITS'
    '@' 
    [ '_:' cObjectName ] strings:Cat
    ';'
   end
   //'%FIELDS'
   //';'
  ';'
 ] Ctx:Parser:PushArray

 [
  'array' 
  'type' 
  g_CurrentClass
 ] Ctx:Parser:PushArray

 axiom:PushSymbol classExpander
 g_CurrentClassImpl Ctx:Parser:PushSymbol

; // class

MACRO class-end
; // class-end

INTEGER type FieldOffset
// - смещение поля

PRIVATE VOID operator MakeMethodSignature
 STRING IN aName
 axiom:PushSymbol :
 [ g_CurrentClass ':' aName ] strings:Cat Ctx:Parser:PushSymbol
; // MakeMethodSignature

MACRO constructor
// - конструктор объектов, пока "фиктивный"
 Literal IN aName
 @SELF Ctx:SetWordProducerForCompiledClass
 g_CurrentClass Ctx:Parser:PushSymbol
 aName |N MakeMethodSignature
; // 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
; // method

MACRO readonly
// - read-only свойство объекта, пока "фиктивное"
 Literal IN aName
 @SELF Ctx:SetWordProducerForCompiledClass
 aName |N MakeMethodSignature
 MakeSelfParam
; // readonly

MACRO new[
 axiom:PushSymbol [
 axiom:PushSymbol @
 g_CurrentClassImpl Ctx:Parser:PushSymbol
; // new[

MACRO RunCompileFields
 [
  'implementation'
  g_CurrentClassImpl
   '%FIELDS'
   for g_CurrentClassMembers ( STRING IN aName [ '`' aName '`' ] strings:Cat )
   ';'
  '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 : getClassName
 IN Self
 Self |N ':' string:Split =: Result DROP
; // getClassName

STRING readonly ClassName
 Self Object:class getClassName =: Result
; // Object:ClassName

class-end // Object

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

USES
 CodeDump.ms.dict
;

@SELF DumpElement

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

for l_Points Point:Print
for l_Points ( Point:X Print )
for l_Points ( Point:Y Print )
for l_Points ( Object:class Print )
for l_Points ( Object: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

for l_Rectangles Rectangle: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