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

Эмуляция объектов на скриптах. Добавлено наследование классов.

Реализация:

Object.ms.dict

UNIT Object.ms.dict

USES
 Bind.ms.dict
;

EXPORTS
 Bind.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
 io.ms.dict
 Debug.ms.dict
 CompileTimeVar.ms.dict
;

EXPORTS
 CompileTimeVar.ms.dict

EXPORTS
 implementation.ms.dict

USES
 InheritsAndImplementsNew.ms.dict
;

EXPORTS
 InheritsAndImplementsNew.ms.dict

WordAlias Log .

WordAlias %R .Implemented.Words
WordAlias %G .Inherited.Words

OBJECT FUNCTION DoMember 
 OBJECT IN aMember
 aMember DO >>> Result
; // DoMember

BOOLEAN FUNCTION FilterMember 
 OBJECT IN aMember
 Result := ( aMember NotValid ! )
; // FilterMember
 
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 CompileTime-VAR g_MetaListPoducerNames []
 %REMARK 'Список содержащий пары (имя списка, указатель на массив)'

CONST cMetaListPoducerNamesElementSize 2

ARRAY FUNCTION MetaListPoducerIt
 g_MetaListPoducerNames .slice> cMetaListPoducerNamesElementSize >>> Result
; // MetaListPoducerIt

CONST cMetaListPrefix '%'

ARRAY FUNCTION MapToName
 ARRAY IN aArray
 aArray .map> |N >>> Result
; // MapToName

CONST cResult 'Result'

CONST cSelf 'Self'

MACRO DefineMetaList
  Literal IN aWordName
  Literal IN aDoc

 %SUMMARY 'Определяет список мета-информации к элементу. И итератор к нему' ;

 STRING VAR l_WordName
 aWordName |N >>> l_WordName
 [ cMetaListPrefix l_WordName ] strings:Cat >>> l_WordName

 STRING VAR l_ListName
 [ '.' l_WordName '.It' ] strings:Cat >>> l_ListName

 l_WordName array:AddTo g_MetaListPoducerNames

 STRING VAR l_ListForValues
 [ 'g_' l_WordName ] strings:Cat >>> l_ListForValues
 axiom:PushSymbol ARRAY
 axiom:PushSymbol CompileTime-VAR
 axiom:PushStringAsSymbol l_ListForValues
 axiom:PushSymbol []

 axiom:PushSymbol [EXECUTE]
 axiom:PushSymbol (
 axiom:PushSymbol @
 axiom:PushStringAsSymbol l_ListForValues
 axiom:PushSymbol array:AddTo 
 axiom:PushSymbol g_MetaListPoducerNames
 axiom:PushSymbol )

 axiom:PushSymbol NamedWordProducer
 [ 
  l_WordName
  l_ListName 
 ] Ctx:Parser:PushArray

 axiom:PushSymbol ARRAY
 axiom:PushSymbol FUNCTION
 axiom:PushStringAsSymbol l_ListName
 axiom:PushSymbol TtfwWord
 axiom:PushSymbol IN
 axiom:PushStringAsSymbol cSelf
 axiom:PushSymbol %SUMMARY
 aDoc |N Ctx:Parser:PushString
 axiom:PushSymbol ; 
 axiom:PushStringAsSymbol cSelf
 axiom:PushSymbol %ClassRTTIList
 axiom:PushStringAsSymbol l_ListName 
 axiom:PushSymbol MapToName
 axiom:PushSymbol >>>
 axiom:PushStringAsSymbol cResult
 axiom:PushSymbol ; 
; // DefineMetaList

  PROCEDURE MakeAlias
    STRING IN aProp
    ^ IN aLambda

   axiom:PushSymbol WordAlias
   aProp aLambda DO
  ; // MakeAlias

DefineMetaList Properties 'Свойства класса'
DefineMetaList Methods 'Методы класса'
DefineMetaList MetaMethods 'Методы мета-класса'
DefineMetaList Constructors 'Конструкторы класса'

: CompileSetWordProducerForCompiledClass
  TtfwWord IN aWord
 aWord
 axiom:PushImmediateSymbol Ctx:SetWordProducerForCompiledClass
; // CompileSetWordProducerForCompiledClass

STACK_CHANGING_MACRO class_impl
  Literal IN aName
 %SUMMARY 'Реализация класса.
 Тут мы будем хранить всю информацию о классе - предки, поля, методы'
 ;

 @SELF CompileSetWordProducerForCompiledClass
 axiom:PushSymbol : 
 aName |N Ctx:Parser:PushSymbol
; // class_impl

STRING CompileTime-VAR g_CurrentClass ''
BOOLEAN CompileTime-VAR g_InstanceSizeDefined false
BOOLEAN CompileTime-VAR g_ConstructorsCopied false

TtfwWord type ObjectClass

ObjectClass CompileTime-VAR g_CurrentClassImpl nil
ObjectClass CompileTime-VAR g_CurrentClassParent nil

CONST cMetaPrefix 'c:'
CONST cFieldPrefix 'Offset:'

STRING FUNCTION FieldPrefix
 [ cMetaPrefix cFieldPrefix ] strings:Cat >>> Result
; // FieldPrefix

PRIVATE STRING operator MakeFieldOffsetName
  STRING IN aName

 %SUMMARY 'Делает имя для доступа к полю' ; 
 [ FieldPrefix aName ] strings:Cat >>> Result
; // MakeFieldOffsetName

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

FieldOffset CompileTime-VAR g_ClassFieldOffset 0

VOID operator define_member
  STRING IN aName
  FieldOffset IN aOffset

 axiom:PushSymbol implementation
 g_CurrentClassImpl pop:Word:Name Ctx:Parser:PushSymbol
 axiom:PushSymbol Const
 aName MakeFieldOffsetName Ctx:Parser:PushSymbol
 aOffset Ctx:Parser:PushInt
 axiom:PushSymbol end.

; // define_member

MACRO member
  Literal IN aName
  STRING VAR l_Name

 %SUMMARY 'Определяет член текущего класса' ;
 g_InstanceSizeDefined ?FAIL [ 'Класс ' g_CurrentClass ' уже определён. Нельзя доопределять его члены.' ]
 aName |N >>> l_Name
 Ctx:ClearTypeInfo
 l_Name g_ClassFieldOffset define_member
 Inc g_ClassFieldOffset
; // member

PRIVATE STRING operator MakeMethodSignaturePrim
 STRING IN aClass
 STRING IN aName
 [ aClass ':' aName ] strings:Cat >>> Result
; // MakeMethodSignaturePrim

CONST cClassImplPrefix '_:'

STRING FUNCTION ClassImplName
  STRING IN aName
 [ cClassImplPrefix aName ] strings:Cat >>> Result
; // ClassImplName

Const ClassRefSuffix 'Class'

STRING FUNCTION ClassRefName
  STRING IN aName
 [ aName ClassRefSuffix ] strings:Cat >>> Result
; // ClassRefName

STRING CompileTime-VAR g_CurrentClassMethod ''
STRING CompileTime-VAR g_CurrentClassMethodModifiers ''

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 :
 axiom:PushStringAsSymbol l_Signature
; // MakeMethodSignature

PRIVATE VOID operator MakeSelfParam
 axiom:PushStringAsSymbol g_CurrentClass
 axiom:PushSymbol in
 axiom:PushStringAsSymbol cSelf
; // MakeSelfParam

MACRO method
  Literal IN aName
  ^ IN aParams

 %SUMMARY 'Метод объекта' ;

 STRING VAR l_Name
 aName |N >>> l_Name

 l_Name @SELF bindInPlace
 
 l_Name MakeMethodSignature
 MakeSelfParam

 @SELF NameOf right aParams axiom:Params:PushWithOtherStereo

 l_Name array:?AddTo g_%Methods
; // method

MACRO readonly
  Literal IN aName

 %SUMMARY 'read-only свойство объекта' ;

 STRING VAR l_Name
 aName |N >>> l_Name

 l_Name @SELF bindInPlace

 l_Name MakeMethodSignature
 MakeSelfParam
 l_Name array:?AddTo g_%Properties
; // readonly

STACK_CHANGING_MACRO class_method
  Literal IN aName
  
 %SUMMARY 'Метод класса' ;

 g_CurrentClassMethod '' == ?ASSURE 'Вложенные методы класса пока не поддерживаются'

 TtfwWordInfo VAR l_WordInfo
 Ctx:WordInfo >>> l_WordInfo

 STRING VAR l_TypeInfo
 l_WordInfo pop:WordInfo:TypeName >>> g_CurrentClassMethodModifiers

 STRING VAR l_Name
 aName |N >>> l_Name

 l_Name >>> g_CurrentClassMethod

 l_Name bindAndRestoreContext

 @SELF CompileSetWordProducerForCompiledClass

 axiom:PushSymbol :

 STRING VAR l_ClassName

 g_CurrentClass >>> l_ClassName
 
 l_ClassName ClassRefName >>> l_ClassName

 STRING VAR l_ClassMethodName
 
 l_ClassName l_Name MakeMethodSignaturePrim >>> l_ClassMethodName
 axiom:PushStringAsSymbol l_ClassMethodName

 axiom:PushStringAsSymbol l_ClassName
 axiom:PushSymbol in
 axiom:PushStringAsSymbol cSelf

 l_Name array:?AddTo g_%MetaMethods
; // class_method

CONST cObjectName 'Object'

CONST cInstanceSizeName 'Instance:Size'

STRING FUNCTION InstanceSizeName
 [ cMetaPrefix cInstanceSizeName ] strings:Cat >>> Result
; // InstanceSizeName

CONST cClassParentName 'Class:Parent'

STRING FUNCTION ClassParentName
 [ cMetaPrefix cClassParentName ] strings:Cat >>> Result
; // ClassParentName

CONST cClassTypePrefix 'ClassOf::'

STRING FUNCTION ClassOfName
  STRING IN aClassName
 [ cClassTypePrefix aClassName ] strings:Cat >>> Result
; // ClassOfName

MACRO ClassOf
  Literal IN aName
 STRING VAR l_ClassName
 aName |N ClassOfName >>> l_ClassName
 l_ClassName IsWordDeclared ?ASSURE [ 'Класс ' l_ClassName ' не определён' ]
 axiom:PushStringAsSymbol l_ClassName
; // ClassOf

PROCEDURE ClearMetaLists
 MetaListPoducerIt .for> ( 
   STRING IN aName 
   TtfwWord IN aVar
  [] aVar pop:Word:SetValue
 ) // MetaListPoducerIt .for>
; // ClearMetaLists

PROCEDURE ClearClassInfo
 g_CurrentClass := ''
 g_CurrentClassImpl := nil
 g_CurrentClassParent := nil
 g_InstanceSizeDefined := false
 g_ConstructorsCopied := false
 g_ClassFieldOffset := 0 
 ClearMetaLists
; // ClearClassInfo

MACRO class
 Literal IN aName
 ( g_CurrentClass = '' ) ?ASSURE 'Вложенные классы пока не поддерживаются'

 TtfwWordInfo VAR l_WordInfo
 Ctx:WordInfo >>> l_WordInfo
 Ctx:ClearTypeInfo

 ClearClassInfo

 aName |N >>> g_CurrentClass

 STRING VAR l_TypeInfo
 l_WordInfo pop:WordInfo:TypeName >>> l_TypeInfo

 STRING VAR l_CurrentClassParentName

 if ( l_TypeInfo <> '' ) then
 begin
  l_TypeInfo 'ARRAY' == ?FAIL [ 'Множественное наследование пока не поддерживается. Класс: ' g_CurrentClass ' Заявленные предки ' l_TypeInfo ]
  l_TypeInfo ' ' string:Pos -1 == ?ASSURE [ 'Множественное наследование пока не поддерживается. Класс: ' g_CurrentClass ' Заявленные предки ' l_TypeInfo ]
  l_TypeInfo >>> l_CurrentClassParentName
 end
 else
 begin
  cObjectName >>> l_CurrentClassParentName
 end

 STRING VAR l_CurrentClassImpl
 g_CurrentClass ClassImplName >>> l_CurrentClassImpl

 STRING VAR l_ClassRefName
 g_CurrentClass ClassRefName >>> l_ClassRefName

 if ( g_CurrentClass !== cObjectName ) then
 begin
  axiom:PushImmediateSymbol (
  l_CurrentClassParentName ClassOfName Ctx:Parser:PushSymbol 
  axiom:PushSymbol >>> 
  axiom:PushSymbol g_CurrentClassParent
  axiom:PushSymbol )

  axiom:PushSymbol ObjectClass
  axiom:PushSymbol type
  axiom:PushStringAsSymbol l_ClassRefName
 end // g_CurrentClass !== cObjectName

 axiom:PushStringAsSymbol l_ClassRefName
 axiom:PushSymbol class_impl
 axiom:PushStringAsSymbol l_CurrentClassImpl

 if ( g_CurrentClass !== cObjectName ) then
 begin
  axiom:PushSymbol %INHERITS
  axiom:PushSymbol @
  l_CurrentClassParentName ClassImplName Ctx:Parser:PushSymbol
  axiom:PushSymbol ;
 end

 axiom:PushSymbol @SELF
 axiom:PushSymbol >>>
 axiom:PushStringAsSymbol cResult
 axiom:PushSymbol FieldOffset
 axiom:PushSymbol CompileTime-VAR

 axiom:PushStringAsSymbol InstanceSizeName

 0 Ctx:Parser:PushInt

 axiom:PushSymbol ObjectClass
 axiom:PushSymbol CompileTime-VAR

 axiom:PushStringAsSymbol ClassParentName

 axiom:PushSymbol g_CurrentClassParent

 axiom:PushSymbol ;

 axiom:PushImmediateSymbol (
 axiom:PushStringAsSymbol l_CurrentClassImpl
 axiom:PushSymbol >>>
 axiom:PushSymbol g_CurrentClassImpl
 axiom:PushSymbol )
 axiom:PushSymbol array
 axiom:PushSymbol type
 axiom:PushStringAsSymbol g_CurrentClass
 axiom:PushSymbol WordAlias
 g_CurrentClass ClassOfName Ctx:Parser:PushSymbol
 axiom:PushStringAsSymbol l_CurrentClassImpl

 if ( g_CurrentClass !== cObjectName ) then
 begin
  axiom:PushStringAsSymbol 'classExpander'
  axiom:PushStringAsSymbol l_CurrentClassImpl
 end

; // class

class Object

ObjectClass member VMT
//STRING member Fake
//INTEGER member Fake1

: FieldByOffset
 Object in Self
 FieldOffset right anOffset
 anOffset Self [i]
; // FieldByOffset

PRIVATE operator do_get_member
  STRING IN aName
 
 %SUMMARY 'Определяет способ доступа к члену класса' ;
 axiom:PushSymbol FieldByOffset
 axiom:PushSymbol (
 g_CurrentClass ClassImplName Ctx:Parser:PushSymbol
 axiom:PushSymbol ::
 aName MakeFieldOffsetName Ctx:Parser:PushSymbol 
 axiom:PushSymbol )
; // do_get_member

MACRO read
 Literal IN aName
 axiom:PushStringAsSymbol cSelf
 aName |N do_get_member
 axiom:PushSymbol >>>
 axiom:PushStringAsSymbol cResult
 axiom:PushSymbol ;
; // read

ObjectClass readonly class read VMT

MACRO class_method_end
 axiom:PushSymbol ;
 g_CurrentClassMethodModifiers axiom:PushWordInfo
 axiom:PushSymbol readonly
 axiom:PushStringAsSymbol g_CurrentClassMethod
 axiom:PushStringAsSymbol cSelf
 axiom:PushStringAsSymbol '.class'
 [ '.' g_CurrentClassMethod ] strings:Cat Ctx:Parser:PushSymbol

 if ( g_CurrentClassMethodModifiers IsNil ! ) then
 begin 
  axiom:PushSymbol >>> 
  axiom:PushStringAsSymbol cResult
 end // g_CurrentClassMethodModifiers IsNil !

 axiom:PushSymbol ;
 '' >>> g_CurrentClassMethod
 '' >>> g_CurrentClassMethodModifiers
; // class_method_end

STRING class_method ClassName
 %SUMMARY 'Возвращает имя класса' ;
 Self |N ':' string:Split >>> Result DROP
class_method_end // ClassName

FieldOffset class_method FieldOffset
  // - этод метод можно сделать КОМПИЛИРУЕМЫМ
  Literal IN aFieldName
 
 %SUMMARY 'Вычисляет смещение поля класса' ;
 STRING VAR l_FieldName
 aFieldName |N >>> l_FieldName
 l_FieldName MakeFieldOffsetName >>> l_FieldName

 TtfwWord VAR l_FieldVAR
 Self %% l_FieldName >>> l_FieldVAR

 l_FieldVAR IsNil ?FAIL [ 'Поле ' l_FieldName ' на классе ' Self .ClassName ' не определено' ]
 l_FieldVAR DO >>> Result

class_method_end // FieldOffset

INTEGER class_method InstanceSize
 %SUMMARY 'Возвращает размер экземпляров класса' ;
 Self %% InstanceSizeName DO >>> Result
class_method_end // InstanceSize

ObjectClass class_method ClassParent
 %SUMMARY 'Возвращает родительский класс' ;
 Self %% ClassParentName DO >>> Result
class_method_end // ClassParent

STRING class_method ClassParentName
  %SUMMARY 'Возвращает имя родительского класса' ;
 ObjectClass VAR l_ClassParent
 Self %% ClassParentName DO >>> l_ClassParent
 if ( l_ClassParent IsNil ) then
 begin
  '<base>' >>> Result
 end
 else
 begin
  l_ClassParent .ClassName >>> Result
 end
class_method_end // ClassParentName

class_method Print
 %SUMMARY 'Печатает класс' ;
 if ( Self IsNil ) then
 begin
  '<base>' .
 end
 else
 begin
  Self .ClassName Print
 end
class_method_end // Print

CONST cDefConstructorName 'new'

PROCEDURE DefineInstanceSize
 %SUMMARY 'Определяем размер экземпляров класса' ;
 if ( g_InstanceSizeDefined ! ) then
 begin
  g_InstanceSizeDefined := true

  TtfwWord VAR l_InstanceSizeVAR
  g_CurrentClassImpl %% InstanceSizeName >>> l_InstanceSizeVAR
  l_InstanceSizeVAR IsNil ?FAIL [ 'Переменная для размера класса ' g_CurrentClass ' почему-то не определена' ]
  l_InstanceSizeVAR DO =0 ?ASSURE [ 'Размер класса ' g_CurrentClass ' почему-то уже определён' ]
  g_ClassFieldOffset l_InstanceSizeVAR pop:Word:SetValue
 end // g_InstanceSizeDefined !
; // DefineInstanceSize

FORWARD CopyConstructors

STACK_CHANGING_MACRO constructor
  Literal IN aName
  ^ IN aParams

 %SUMMARY 'Конструктор объектов';

 STRING VAR l_Name
 aName |N >>> l_Name

 DefineInstanceSize
 // - тут определяем размер экземпляров класса

 if ( l_Name <> cDefConstructorName ) then
 begin
  if ( g_ConstructorsCopied ! ) then
  begin
   l_Name Log
   CopyConstructors
  end // g_ConstructorsCopied !
 end // l_Name <> cDefConstructorName
 else
 begin
  g_ConstructorsCopied := true
 end // l_Name <> cDefConstructorName

 g_CurrentClass l_Name MakeMethodSignaturePrim Log

 @SELF CompileSetWordProducerForCompiledClass
 axiom:PushStringAsSymbol g_CurrentClass
 l_Name MakeMethodSignature
 @SELF NameOf right aParams axiom:Params:PushWithOtherStereo

 axiom:PushSymbol WordAlias
 axiom:PushStringAsSymbol cSelf
 axiom:PushStringAsSymbol cResult

 l_Name array:?AddTo g_%Constructors
; // constructor

PROCEDURE def_constructor_do
 axiom:PushSymbol constructor
 axiom:PushStringAsSymbol cDefConstructorName
 axiom:PushSymbol ()
; // def_constructor_do

MACRO def_constructor
 def_constructor_do
; // def_constructor

PROCEDURE def_constructor_empty_do
 def_constructor_do
 axiom:PushStringAsSymbol 'new['
 axiom:PushSymbol ] 
 axiom:PushSymbol >>> 
 axiom:PushStringAsSymbol cResult
 axiom:PushSymbol ;
; // def_constructor_empty_do

MACRO def_constructor_empty
 def_constructor_empty_do
; // def_constructor_empty

PROCEDURE CopyConstructors
 DefineInstanceSize
 if ( g_ConstructorsCopied ! ) then
 begin
  if ( g_CurrentClass !== cObjectName ) then
  begin
   g_CurrentClassImpl IsNil ?FAIL [ 'Нет текущего определяемого класса. Возможное имя класса ' g_CurrentClass ]
   g_ConstructorsCopied := true
   g_CurrentClassImpl %G .for> (
    ObjectClass IN anItem

    anItem .%Constructors.It .for> ( 
     STRING IN aProp
     if ( aProp = cDefConstructorName ) then
     begin
      def_constructor_empty_do
     end
    ) // anItem .%Constructors.It .for>

   ) // anImpl %G .for>
  end // ( g_CurrentClass !== cObjectName ) 
 end // ( g_ConstructorsCopied ! )
; // CopyConstructors

MACRO classExpander
  ^ IN anImpl

 ObjectClass VAR l_Impl 
 anImpl |@ >>> l_Impl

 %SUMMARY 'Тут можно копировать поля и методы' ;
 l_Impl %G .for> ( 
  ObjectClass IN anItem

  anItem MembersIterator
   .filter> ( pop:Word:Producer pop:Word:Name NameOf CONST == )
   .filter> ( pop:Word:Name FieldPrefix SWAP StartsStr )  
   .for> 
  ( 
   TtfwWord IN aMember
   STRING VAR l_MemberName
   [ aMember pop:Word:Name FieldPrefix '' string:ReplaceFirst ] strings:Cat >>> l_MemberName

   FieldOffset VAR l_ClassFieldOffset

   aMember DO >>> l_ClassFieldOffset

   l_MemberName l_ClassFieldOffset define_member

   if ( l_ClassFieldOffset >= g_ClassFieldOffset ) then
   // - тут исправляем "кривизну" с сортировкой
   begin
    g_ClassFieldOffset := l_ClassFieldOffset
    Inc g_ClassFieldOffset
   end

  ) // anItem MembersIterator

  PROCEDURE MakeAliasAndAdd
    STRING IN aProp
    ^ IN anArray
    ^ IN aLambda

   ARRAY VAR l_Array
   anArray DO >>> l_Array
  
   aProp array:?AddTo l_Array
  
   aProp MakeAlias ( aLambda DO )
  ; // MakeAliasAndAdd

  PROCEDURE PushMethodSignature
    STRING IN aClass
    STRING IN aName
   aClass aName MakeMethodSignaturePrim Ctx:Parser:PushSymbol
  ; // PushMethodSignature

  PROCEDURE PushMethodSignatureAlias
   STRING IN aProp 
   g_CurrentClass aProp PushMethodSignature
   anItem .ClassName aProp PushMethodSignature
  ; // PushMethodSignatureAlias

  PROCEDURE .for.MakeAliasAndAdd>
   ARRAY IN aArray
   ^ IN anRArray
   ^ IN aLambda
   aArray .for> MakeAliasAndAdd ( anRArray DO ) ( aLambda DO )
  ; // .for.MakeAliasAndAdd>

  anItem .%Properties.It .for.MakeAliasAndAdd> g_%Properties PushMethodSignatureAlias

  anItem .%Methods.It .for.MakeAliasAndAdd> g_%Methods PushMethodSignatureAlias 

  anItem .%MetaMethods.It .for.MakeAliasAndAdd> g_%MetaMethods ( 
   STRING IN aProp
   g_CurrentClass ClassRefName aProp PushMethodSignature
   anItem .ClassName ClassRefName aProp PushMethodSignature
  )

 ) // l_Impl %G .for>

; // classExpander

: ListToNameAsString
  STRING IN aName
  ARRAY IN aList

 %SUMMARY 'Выводит элементы массива как строки в список метаинформации aName' ;

 //aList DO >>> l_List
 //ARRAY VAR l_List
 aName
 %REMARK 'Открываем список'
  aList .for> NameAsString
 ';'
 %REMARK 'Закрываем список'
; // ListToNameAsString

PROCEDURE FinishClassDefinition
 axiom:PushSymbol implementation

 g_CurrentClassImpl pop:Word:Name Ctx:Parser:PushSymbol
 [
   MetaListPoducerIt .for> ( 
     STRING IN aName 
     TtfwWord IN aVar 

    aName aVar DO ListToNameAsString 
   ) // MetaListPoducerIt .for>

 ] Ctx:Parser:PushArray

 axiom:PushSymbol end.
 ClearClassInfo
; // FinishClassDefinition

MACRO class-end
 //DefineInstanceSize

 axiom:PushImmediateSymbol CopyConstructors

 axiom:PushImmediateSymbol FinishClassDefinition
; // class-end

MACRO new[
 INTEGER VAR l_InstanceSize
 ClassOf Object .InstanceSize >>> l_InstanceSize
 Dec l_InstanceSize
 //l_InstanceSize .

 axiom:PushSymbol [
 axiom:PushSymbol @
 g_CurrentClassImpl pop:Word:Name Ctx:Parser:PushSymbol
 
 l_InstanceSize LOOP ( 'uninited member' Ctx:Parser:PushString )
; // new[

def_constructor_empty

VIRTUAL STRING readonly ToPrintable
 Self ToPrintable >>> Result
 [ Self .ClassName ' : ' Result ] strings:Cat >>> Result
 //Self .ClassName >>> Result
; // ToPrintable

VIRTUAL void readonly Print
 Self .ToPrintable Print
; // Print

class-end // Object

Тест:

Object.ms.script

USES
 io.ms.dict
 Object.ms.dict
 Testing.ms.dict
;

USES
 axiom:WordInfo
;

Test&Dump ObjectTest

 ClassOf Object DumpElement

 ClassOf Object pop:Word:Name Print

 Object VAR l_Obj
 l_Obj := Object:new

 l_Obj .Print
 l_Obj .ClassName Print

 //@ l_Obj pop:Word:Info pop:WordInfo:ValueTypes Print
 //@ l_Obj pop:Word:Info pop:WordInfo:ValueTypes pop:ValueTypes:Name Print
 l_Obj .ClassName Print
 ClassOf Object pop:Word:Name Print

 '--------' Print

 l_Obj .InstanceSize Print

 ClassOf Object .FieldOffset VMT Print
 ClassOf Object .ClassParent Print
 ClassOf Object .ClassParent .Print
 ClassOf Object .ClassParentName Print

 ClassOf Object pop:Word:Name Print
 ClassOf Object pop:Word:Name Print

 l_Obj .class Print
 l_Obj .class .Print

 class Object1
  //def_constructor_empty
 class-end // Object1

 Object1 VAR l_Obj1
 l_Obj1 := Object1:new

 l_Obj1 .Print
 l_Obj1 .ClassName Print

 '--------' Print

 l_Obj1 .InstanceSize Print
 
 ClassOf Object1 .FieldOffset VMT Print
 ClassOf Object1 .ClassParent Print
 ClassOf Object1 .ClassParent .Print
 ClassOf Object1 .ClassParentName Print

 l_Obj1 .class Print
 l_Obj1 .class .Print

 class Object2
  INTEGER member FakeField
  INTEGER readonly FakeField read FakeField
  def_constructor
   //[EXECUTE] ( g_InstanceSizeDefined Msg )
   new[ 256 ] >>> Result 
   //Self .FieldOffset 'VMT' Msg
  ; // new
 class-end // Object2

 Object2 VAR l_Obj2
 l_Obj2 := Object2:new

 l_Obj2 .Print
 l_Obj2 .ClassName Print

 '--------' Print

 l_Obj2 .InstanceSize Print

 ClassOf Object2 .FieldOffset VMT Print
 ClassOf Object2 .FieldOffset FakeField Print
 ClassOf Object2 .ClassParent Print
 ClassOf Object2 .ClassParent .Print
 ClassOf Object2 .ClassParentName Print
 ClassOf Object2 .FieldOffset FakeField Print

 l_Obj2 .FakeField Print

 l_Obj2 .class Print
 l_Obj2 .class .Print
 //l_Obj2 .member FakeField Print

 Object2 class Object3
  def_constructor
   new[ 257 ] >>> Result 
  ; // new
 class-end // Object3

 '--------' Print

 ClassOf Object3 Print
 ClassOf Object3 ObjectClass:ClassName Print
 ClassOf Object3 ObjectClass:ClassParent Print
 ClassOf Object3 ObjectClass:ClassParentName Print

 '--------' Print

 ClassOf Object3 .Print
 ClassOf Object3 .ClassName Print
 ClassOf Object3 .ClassParent Print
 ClassOf Object3 .ClassParentName Print

 Object3 VAR l_Obj3
 l_Obj3 := Object3:new

 l_Obj3 .Print
 l_Obj3 .ClassName Print

 '--------' Print

 l_Obj3 .InstanceSize Print

 ClassOf Object3 .FieldOffset VMT Print
 ClassOf Object3 .FieldOffset FakeField Print
 ClassOf Object3 .ClassParent Print
 ClassOf Object3 .ClassParent .Print
 ClassOf Object3 .ClassParentName Print
 ClassOf Object3 .FieldOffset FakeField Print

 l_Obj3 .FakeField Print

 l_Obj3 .class Print
 l_Obj3 .class .Print

 class Object4
  //def_constructor_empty
 class-end // Object4

 Object4 VAR l_Obj4
 l_Obj4 := Object4:new

 l_Obj4 .Print
 l_Obj4 .ClassName Print

 '--------' Print

 l_Obj4 .InstanceSize Print
 
 ClassOf Object4 .FieldOffset VMT Print
 ClassOf Object4 .ClassParent Print
 ClassOf Object4 .ClassParent .Print
 ClassOf Object4 .ClassParentName Print

 l_Obj4 .class Print
 l_Obj4 .class .Print

; // ObjectTest

ObjectTest

Запись Object2 class Object3 - описывает Object3 наследующийся от Object2.