#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.

#1175. Придумал, что делать с генерацией и переходом на "новые скрипты"

Придумал, что делать с генерацией и переходом на "новые скрипты".

В общем - делаем "старые скрипты", которые генерируют "новые скрипты", которые генерируют код.

И так - итеративно. Пока "старых скриптов" не останется.

Чуть позже опишу идею.

"Код который сам себя пишет". Звучит ИДИОТСКИ - я знаю. Но это так.

Пока заготовочка:

PROGRAM GenerateUnit.ms.script

CONST cPathSep '\'

STRING FUNCTION OutDir
 sysutils:GetCurrentDir >>> Result
 [ Result
  script:FileName 
  %REMARK 'Путь к текущему скрипту'
  sysutils:ExtractFileName
  %REMARK 'Вырезаем из пути только имя файла' 
  '' sysutils:ChangeFileExt
  %REMARK 'Убираем .script' 
  '' sysutils:ChangeFileExt 
  %REMARK 'Убираем .ms' 
 ] cPathSep strings:CatSep >>> Result
; // OutDir

STRING FUNCTION MakeOutPath
 OutDir >>> Result
 Result sysutils:ForceDirectories ?ASSURE [ 'Не удалось создать директорию ' Result ]
; // MakeOutPath

USES
 CompileTimeVar.ms.dict
;

FILE CompileTime-VAR g_OutFile nil
%REMARK 'Текущий файл'

INTEGER CompileTime-VAR g_Indent 0
%REMARK 'Текущий отступ'

STRING INTEGER ARRAY TYPE OUTABLE

CONST cIndentChar ' '

FORWARD ValueToString

STRING FUNCTION ValueToString
  OUTABLE IN aValue

 if ( aValue IsArray ) then
  ( [ aValue .for> ValueToString ] strings:Cat >>> Result )
 else
  ( aValue ToPrintable >>> Result )
; // ValueToString

PROCEDURE OutToFile
  OUTABLE IN aValue 

 %SUMMARY 
 '
 Выводит значение в текущий файл вывода.
 БЕЗ перевода каретки.
 '
 ; // %SUMMARY 

 [ g_Indent cIndentChar char:Dupe aValue ValueToString ] strings:Cat g_OutFile File:WriteStr
 %REMARK '- выводим элементы модели в файл, а не в стандартный вывод.'
; // OutToFile

CONST \n #13#10

PROCEDURE OutToFileLn
  OUTABLE IN aValue
 
 %SUMMARY 
 '
 Выводит значение в текущий файл вывода.
 С переводом каретки.
 '
 ; // %SUMMARY 

 aValue OutToFile
 %REMARK '- выводим элементы модели в файл, а не в стандартный вывод.'
 \n g_OutFile File:WriteStr
 %REMARK '- выводим перевод каретки'
; // OutToFileLn

PROCEDURE array:OutToFileLn
  ARRAY IN aValue

 %SUMMARY 'Выводит значения элементов массива построчно' ;
 aValue .for> OutToFileLn
; // array:OutToFileLn

USES
 SaveVarAndDo.ms.dict
;

: ExpandLambda
   FUNCTOR IN aLambda

  ARRAY VAR l_LambdaCode
  [ aLambda DO ] >>> l_LambdaCode
  if ( l_LambdaCode Array:Count <> 0 ) then
  begin
   [
   l_LambdaCode .for> (
    IN aValue
    aValue
    \n
   )
   ]
  end
; // ExpandLambda

ARRAY CompileTime-VAR g_OutedUnits []
ARRAY CompileTime-VAR g_OutedClasses []

PROCEDURE GenerateUnit
  STRING IN aUnitName
  ^ IN anInterfaceLambda
  ^ IN anImplementationLambda

 aUnitName IsNil ?FAIL 'Имя модуля не может быть пустым'

 aUnitName g_OutedUnits array:Has ?FAIL [ 'Модуль ' aUnitName ' уже генерировался' ]

 aUnitName array:AddTo g_OutedUnits
 
 STRING VAR l_UnitFileName 
 [ aUnitName '.pas' ] strings:Cat >>> l_UnitFileName

 STRING VAR l_UnitPath
 MakeOutPath >>> l_UnitPath
 [ l_UnitPath cPathSep l_UnitFileName ] strings:Cat >>> l_UnitPath
 l_UnitPath Print

 TF g_OutedClasses (
  [] >>> g_OutedClasses
  l_UnitPath File:OpenWrite >>> g_OutFile
  TF g_OutFile (
   [
    [ 'unit' ' ' aUnitName ';' ]
    ''
    'interface'
    ''
    anInterfaceLambda ExpandLambda
    'implementation'
    ''
    anImplementationLambda ExpandLambda
    'end.'
   ] array:OutToFileLn
  ) // TF g_OutFile
 ) // TF g_OutedClasses
; // GenerateUnit 

: GenerateClass
  STRING IN aClassName

 aClassName g_OutedClasses array:Has ?FAIL [ 'Класс ' aClassName ' уже генерировался' ]

 aClassName array:AddTo g_OutedClasses
 aClassName IsNil ?FAIL 'Имя класса не может быть пустым'
 'type'
 aClassName
 'end;'
 ''
; // GenerateClass

USES
 Testing.ms.dict
;

Test&Dump GenerateUnitTest
 TF g_OutedUnits (
  'Unit1' GenerateUnit ( 
   'TTest1' GenerateClass 
   'TTest2' GenerateClass
   'TTest3' GenerateClass
  ) ()
  g_OutedClasses Print

  'Unit2' GenerateUnit ( 'test' ) ( 'test' )
  g_OutedClasses Print

  'Unit3' GenerateUnit () ()
  'Unit4' GenerateUnit () ()

  g_OutedUnits Print
 )
; // GenerateUnitTest

GenerateUnitTest

#1173. Пора писать книгу "психбольница в руках пациентов по-русски"

Пора писать книгу "психбольница в руках пациентов по-русски".

В духе Джоэла.

Боюсь только неполиткорректно получится.

Про то как "RUP внедряли". Зачем? И почему?

И "не внедрили".

И чем RUP лучше Agile.

И как кучу "макулатуры" написали.

И про то, что без "макулатуры" ещё хуже.

Про "коней в вакууме".

Про "фреймворки" и как они "не ложатся" на требования пользователей.

И почему "программисты" НЕ ДОЛЖНЫ в одиночку писать "фреймворки".

Про то как "решения принимаются".

Про то, что UML - "беда", но без UML - "беда ещё больше".

И как "Supports враги придумали".

И почему многие беды от недостатка "изобразительных средств", а также от недостатка "уровней абстракции" в целевом языке.

И про то как "мы увлекаемся идеями китов индустрии", а они на самом деле - сами не знают "куда идти".

И о том, что НЕВОЗМОЖНО применять один инструмент и один подход для решения задач "разных масштабов".

"Задел" тут - #1154. О "графической нотации".

#1172. Тестирование скриптовых слов. Только код

Определения слов и тесты:

UNIT string.ms.dict

USES
 Documentation.ms.dict
 params.ms.dict
 core.ms.dict
 map.ms.dict
 Testing.ms.dict
 io.ms.dict
;

: (string)
 ^ IN aValue
 aValue DO ToPrintable
; // (string)

STRING FUNCTION string:CatWihAny
 STRING IN aString
 IN aValue
 aString aValue ToPrintable Cat =: Result
; // string:CatWihAny

STRING FUNCTION any:Cat
 ARRAY IN anArray
 anArray .map> ToPrintable strings:Cat =: Result
; // any:Cat

TestsFor any:Cat
 Test T1 [ 'A' 123 'B' ] any:Cat Print ;
 Test T2 [ 'A' 124 'B' ] any:Cat Print ;
; // TestsFor any:Cat

STRING FUNCTION (+)?
 STRING in aPrefix
 STRING right aSuffix
 %SUMMARY 'Если aSuffix не пустой, то возвращает сумму aPrefix и aSuffix, иначе возвращает пустую строку' ;
 Result := ''
 STRING VAR l_Suffix
 aSuffix =: l_Suffix
 if ( l_Suffix =/= '' ) then
  ( aPrefix l_Suffix Cat =: Result )
; // (+)?

TestsFor (+)?
 Test T1 '' (+)? 'B' Print ;
 Test T2 'A' (+)? 'B' Print ;
 Test T3 'A' (+)? '' Print ;
 Test T4 'A' (+)? 'D' Print ;
 Test T5 'A' (+)? '123' Print ;
; // TestsFor (+)?

STRING FUNCTION ?(+)
 STRING in aPrefix
 STRING right aSuffix
 %SUMMARY 'Если aPrefix не пустой, то возвращает сумму aPrefix и aSuffix, иначе возвращает пустую строку' ;
 Result := ''
 if ( aPrefix =/= '' ) then
  ( aPrefix aSuffix Cat =: Result )
; // ?(+)

TestsFor ?(+)
 Test T1 '' ?(+) 'B' Print ;
 Test T2 'A' ?(+) 'B' Print ;
 Test T3 'A' ?(+) '' Print ;
; // TestsFor ?(+)

STRING FUNCTION strings:CatSep>
 STRING right aSep
 ARRAY right aValues
 aValues aSep strings:CatSep =: Result
; // strings:CatSep>

TestsFor strings:CatSep>
 Test T1 strings:CatSep> ' ' [ 'A' 'B' ] Print ;
 Test T2 strings:CatSep> ' ' [ 'A ' 'B' ] Print ;
 Test T3 strings:CatSep> ' ' [ 'A ' ' B' ] Print ;
 Test T4 strings:CatSep> ' ' [ 'A' ' B' ] Print ;
 Test T5 strings:CatSep> ' ' [ '' 'B' ] Print ;
 Test T6 strings:CatSep> ' ' [ 'A' '' ] Print ;
; // TestsFor strings:CatSep>
 
WordAlias CatSep> strings:CatSep>

PROCEDURE string:Split:for>
  STRING IN aString
  STRING IN aSep
  ^ IN aLambda

 %SUMMARY 'Разделяет строку aString по разделителю aSep и для каждой части вызывает aLambda' ;

 while ( aString IsNil ! ) 
 begin
  aSep string:SplitTo! aString
  STRING VAR l_Part
  >>> l_Part
  if ( l_Part IsNil ! ) then
  begin
   l_Part aLambda DO
  end
 end
; // string:Split:for>

TestsFor string:Split:for>
 Test T1 'a b c' ' ' string:Split:for> Print ;
 Test T2 'a b  c' ' ' string:Split:for> Print ;
 Test T3 'abc' ' ' string:Split:for> Print ;
 Test T4 '' ' ' string:Split:for> Print ;
 Test T5 ' ' ' ' string:Split:for> Print ;
; // string:Split:for> 

Вызов тестов:

PROGRAM String.ms.script

USES
 string.ms.dict
 Testing.ms.dict
;

Test&Dump StringTest
 RunTests.in.array @[ (+)? ?(+) strings:CatSep> any:Cat string:Split:for> ]
  %REMARK 'Запускаем тесты к указанным скриптовым словам'
; // StringTest

StringTest

#1171. Коротко. Боролся тут с непечатью из нашего продукта на неумолчательный принтер

Боролся тут с непечатью из нашего продукта на неумолчательный принтер.

Ох ну там и "макароны".

Вот:

procedure TPrinter.SetPrinter(ADevice, ADriver, APort: PChar; ADeviceMode: THandle);
var
  I, J: Integer;
  StubDevMode: TDeviceMode;
  BufSize: Longint;
begin
  CheckPrinting(False);
  if ADeviceMode <> DeviceMode then
  begin  // free the devmode block we have, and take the one we're given
    if DeviceMode <> 0 then
    begin
      GlobalUnlock(DeviceMode);
      GlobalFree(DeviceMode);
    end;
    DeviceMode := ADeviceMode;
  end;
  if DeviceMode <> 0 then
  begin
    DevMode := GlobalLock(DeviceMode);
    SetPrinterCapabilities(DevMode.dmFields);
  end;
  FreeFonts;
  if FPrinterHandle <> 0 then
  begin
    ClosePrinter(FPrinterHandle);
    FPrinterHandle := 0;
  end;
  SetState(psNoHandle);
  J := -1;
  with Printers do   // < - this rebuilds the FPrinters list
    for I := 0 to Count - 1 do
    begin
      if TPrinterDevice(Objects[I]).IsEqual(ADriver, ADevice, APort) then
      begin
        TPrinterDevice(Objects[I]).Port := APort;
        J := I;
        Break;
      end;
    end;
  if J = -1 then
  begin
    J := FPrinters.Count;
    FPrinters.AddObject(Format(SDeviceOnPort, [ADevice, APort]),
      TPrinterDevice.Create(ADriver, ADevice, APort));
  end;
  FPrinterIndex := J;
  if OpenPrinter(ADevice, FPrinterHandle, nil) then
  begin
    if DeviceMode = 0 then  // alloc new device mode block if one was not passed in
    begin
      BufSize := DocumentProperties(0, FPrinterHandle, ADevice, StubDevMode, StubDevMode, 0);
      if BufSize > 0 then {V}
        DeviceMode := GlobalAlloc(GHND, BufSize);
      if DeviceMode <> 0 then
      begin
        DevMode := GlobalLock(DeviceMode);
        if DocumentProperties(0, FPrinterHandle, ADevice, DevMode^,
          DevMode^, DM_OUT_BUFFER) < 0 then
        begin
          GlobalUnlock(DeviceMode);
          GlobalFree(DeviceMode);
          DeviceMode := 0;
        end
      end;
    end;
    if DeviceMode <> 0 then
      SetPrinterCapabilities(DevMode^.dmFields);
  end;
end;

...
procedure TPrinter.SetToDefaultPrinter;
var
  I: Integer;
  ByteCnt, StructCnt: DWORD;
  DefaultPrinter: array[0..1023] of Char;
  Cur, Device: PChar;
  PrinterInfo: PPrinterInfo5;
begin
  ByteCnt := 0;
  StructCnt := 0;
  if not EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, nil, 0, ByteCnt,
    StructCnt) and (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then
  begin
    // With no printers installed, Win95/98 fails above with "Invalid filename".
    // NT succeeds and returns a StructCnt of zero.
    if GetLastError = ERROR_INVALID_NAME then
      RaiseError(SNoDefaultPrinter)
    else
      RaiseLastOSError;
  end;
  PrinterInfo := AllocMem(ByteCnt);
  try
    EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, PrinterInfo, ByteCnt, ByteCnt,
      StructCnt);
    if StructCnt > 0 then
      Device := PrinterInfo.pPrinterName
    else begin
      GetProfileString('windows', 'device', '', DefaultPrinter,
        SizeOf(DefaultPrinter) - 1);
      Cur := DefaultPrinter;
      Device := FetchStr(Cur);
    end;
    with Printers do
      for I := 0 to Count-1 do
      begin
        if AnsiSameText(TPrinterDevice(Objects[I]).Device, Device) then
        begin
          with TPrinterDevice(Objects[I]) do
            SetPrinter(PChar(Device), PChar(Driver), PChar(Port), 0);
          Exit;
        end;
      end;
  finally
    FreeMem(PrinterInfo);
  end;
  RaiseError(SNoDefaultPrinter);
end;

DevMode, DeviceMode, TPrinterDevice, with, StringList.

Масса "вкусностей".

Особенно "доставляет" вот это: "< - this rebuilds the FPrinters list"

Т.е. парни что-то "закостыляли" и оставили себе "напоминалку".

Что Borland, что MicroSoft - "на высоте".

"Вкус" программирования тут по моему скромному мнению - отсутствует напрочь.

А я привык "учиться у других".

Но конкретно тут - "сложно учиться".

Ну и Embarcadero к сожалению код так и не переработала, только щедро добавили IfDef:

[PrintingPermission(SecurityAction.LinkDemand, Level=PrintingPermissionLevel.AllPrinting)]
{$IF DEFINED(CLR)}
procedure TPrinter.SetPrinter(ADevice, ADriver, APort: string; ADeviceMode: IntPtr);
{$ELSE}
procedure TPrinter.SetPrinter(ADevice, ADriver, APort: PChar; ADeviceMode: THandle);
{$ENDIF}
var
  I, J: Integer;
{$IF DEFINED(CLR)}
  LDevMode: TDeviceMode;
{$ENDIF}
begin
  CheckPrinting(False);
{$IF DEFINED(CLR)}
  if ADeviceMode <> FDeviceMode then
    UpdateDeviceMode(ADeviceMode);
  if FDeviceMode <> nil then
  begin
    LDevMode := TDeviceMode(Marshal.PtrToStructure(FDeviceMode, TypeOf(TDeviceMode)));
    SetPrinterCapabilities(LDevMode.dmFields);
  end;
{$ELSE}
  if ADeviceMode <> FDeviceMode then
  begin  // free the devmode block we have, and take the one we're given
    if FDeviceMode <> 0 then
    begin
      GlobalUnlock(FDeviceMode);
      GlobalFree(FDeviceMode);
      FDevMode := nil;
    end;
    FDeviceMode := ADeviceMode;
  end;
  if FDeviceMode <> 0 then
  begin
    FDevMode := GlobalLock(FDeviceMode);
    SetPrinterCapabilities(FDevMode.dmFields);
  end;
{$ENDIF}
  FreeFonts;
  if FPrinterHandle <> 0 then
  begin
    ClosePrinter(FPrinterHandle);
    FPrinterHandle := 0;
  end;
  SetState(TPrinterState.psNoHandle);
  J := -1;
  with Printers do   // <- this rebuilds the FPrinters list
    for I := 0 to Count - 1 do
    begin
      if TPrinterDevice(Objects[I]).IsEqual(ADriver, ADevice, APort) then
      begin
        TPrinterDevice(Objects[I]).Port := APort;
        J := I;
        Break;
      end;
    end;
  if J = -1 then
  begin
    J := FPrinters.Count;
    FPrinters.AddObject(Format(SDeviceOnPort, [ADevice, APort]),
      TPrinterDevice.Create(ADriver, ADevice, APort));
  end;
  FPrinterIndex := J;
  if OpenPrinter(ADevice, FPrinterHandle, nil) then
  begin
{$IF DEFINED(CLR)}
    if FDeviceMode = nil then  // alloc new device mode block if one was not passed in
    begin
      FDeviceMode := Marshal.AllocHGlobal(
        DocumentProperties(0, FPrinterHandle, ADevice, FDeviceMode, FDeviceMode, 0));  //set to intptr 0,0
      if FDeviceMode <> nil then
        if DocumentProperties(0, FPrinterHandle, ADevice, FDeviceMode, 0, DM_OUT_BUFFER) < 0 then
          UpdateDeviceMode(nil)
    end;
    if FDeviceMode <> nil then
      SetPrinterCapabilities(LDevMode.dmFields);
{$ELSE}
    if FDeviceMode = 0 then  // alloc new device mode block if one was not passed in
    begin
      FDeviceMode := GlobalAlloc(GHND, DocumentProperties(0, FPrinterHandle, ADevice, nil, nil, 0));

      if FDeviceMode <> 0 then
      begin
        FDevMode := GlobalLock(FDeviceMode);
        if DocumentProperties(0, FPrinterHandle, ADevice, FDevMode, nil, DM_OUT_BUFFER) < 0 then
        begin
          GlobalUnlock(FDeviceMode);
          GlobalFree(FDeviceMode);
          FDeviceMode := 0;
          FDevMode := nil;
        end
      end;
    end;
    if FDeviceMode <> 0 then
      SetPrinterCapabilities(FDevMode^.dmFields);
{$ENDIF}
  end;
end;
...
procedure TPrinter.SetToDefaultPrinter;
var
  I: Integer;
  ByteCnt, StructCnt: DWORD;
{$IF DEFINED(CLR)}
  Device: string;
  PrinterInfo, NamePtr: IntPtr;
  PD: System.Drawing.Printing.PrintDocument;
{$ELSE}
  DefaultPrinter: array[0..1023] of Char;
  Cur, Device: PChar;
  PrinterInfo: PPrinterInfo5;
{$ENDIF}
begin
  ByteCnt := 0;
  StructCnt := 0;
  if not EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, nil, 0, ByteCnt,
    StructCnt) and (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then
  begin
    // With no printers installed, Win95/98 fails above with "Invalid filename".
    // NT succeeds and returns a StructCnt of zero.
    if GetLastError = ERROR_INVALID_NAME then
      RaiseError(SNoDefaultPrinter)
    else
      RaiseLastOSError;
  end;
{$IF DEFINED(CLR)}
  PrinterInfo := Marshal.AllocHGlobal(ByteCnt);
  try
    EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, PrinterInfo, ByteCnt, ByteCnt,
      StructCnt);
    if StructCnt > 0 then
    begin
      NamePtr := Marshal.ReadIntPtr(PrinterInfo, 0); // pPrinterName
      Device := Marshal.PtrToStringAuto(NamePtr);
    end;
  finally
    Marshal.FreeHGlobal(PrinterInfo);
  end;
  if StructCnt <= 0 then {EnumPrinters didnt work, try using CLR}
  begin
    PD := System.Drawing.Printing.PrintDocument.Create;
    Device := PD.DefaultPageSettings.PrinterSettings.PrinterName;
  end;
  with Printers do
    for I := 0 to Count-1 do
    begin
      if WideSameText(TPrinterDevice(Objects[I]).Device, Device) then
      begin
        with TPrinterDevice(Objects[I]) do
          SetPrinter(Device, Driver, Port, nil);
        Exit;
      end;
    end;
{$ELSE}
  PrinterInfo := AllocMem(ByteCnt);
  try
    EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, PrinterInfo, ByteCnt, ByteCnt,
      StructCnt);
    if StructCnt > 0 then
      Device := PrinterInfo.pPrinterName
    else
    begin
{$IF DEFINED(UNICODE)}
      I := Length(DefaultPrinter);
      if not GetDefaultPrinter(DefaultPrinter, I) then
        ZeroMemory(@DefaultPrinter[0], I * SizeOf(Char));
{$ELSE}
      GetProfileString('windows', 'device', '', DefaultPrinter, SizeOf(DefaultPrinter) - 1);
{$ENDIF}
      Cur := DefaultPrinter;
      Device := FetchStr(Cur);
    end;
    with Printers do
      for I := 0 to Count-1 do
      begin
        if AnsiSameText(TPrinterDevice(Objects[I]).Device, Device) then
        begin
          with TPrinterDevice(Objects[I]) do
            SetPrinter(PChar(Device), PChar(Driver), PChar(Port), 0);
          Exit;
        end;
      end;
  finally
    FreeMem(PrinterInfo);
  end;
{$ENDIF}
  RaiseError(SNoDefaultPrinter);
end;

В чём была проблема? А в том, что тут:

    if Assigned(CreateHandleFunc) then
      with TPrinterDevice(Printers.Objects[PrinterIndex]) do
      begin
        DC := CreateHandleFunc(PChar(Driver), PChar(Device), PChar(Port), DevMode);

Driver был от ОДНОГО (неумолчательного) принтера, а DevMode от ПРЕДЫДУЩЕГО (умолчательного).

И некоторые драйвера принтеров "плюют" на это, а некоторые (видимо более дотошные) - возвращают код ошибки.

Как так получилось - пока до конца не понял. Но - "залечил".

Перечитыванием настроек из принтера.

Но тут - "ПЯТЁРКА с ПЛЮСОМ" Майкрософту.

Вообще не очень понятно - "зачем плодить и дублировать сущности".

Да и к классу TPrinter - у меня много вопросов. С SRP - там явно проблемы.

А уж публикация "кишочков" через GetPrinter/SetPrinter - это отдельная песня.

Ну и DocumentProperties - вот уж точно - НЕ SRP. И швец и жнец и на дуде игрец.

И читает свойства, и пишет, да ещё и диалог показывает.

Молодцы короче - ВСЕ. И Borland, и Microsoft, и Embarcadero, да и я с коллегами. Тоже...

Вот так - не работает:

function Tl3Printer.Clone: Il3Printer;
//#UC START# *49BAA14602EC_4799D40F0004_var*

 function CopyData(Handle: THandle): THandle;
 var
   Src, Dest: PChar;
   Size: Integer;
 begin
   if Handle <> 0 then
   begin
     Size := GlobalSize(Handle);
     Result := GlobalAlloc(GHND, Size);
     if Result <> 0 then
       try
         Src := GlobalLock(Handle);
         Dest := GlobalLock(Result);
         if (Src <> nil) and (Dest <> nil) then l3Move(Src^, Dest^, Size);
       finally
         GlobalUnlock(Handle);
         GlobalUnlock(Result);
       end
   end
   else Result := 0;
 end;

var
 l_PrinterIndex : Integer;
 l_Device,
 l_Driver,
 l_Port        : Array[0..255] of Char;
 l_hDeviceMode : THandle;
//#UC END# *49BAA14602EC_4799D40F0004_var*
begin
//#UC START# *49BAA14602EC_4799D40F0004_impl*
  Result := nil;
  l_PrinterIndex := Self.PrinterIndex; // Если что-то с принтером, то лучше упадем уже здесь...
  Result := Make;
  Result.PrinterIndex := l_PrinterIndex;
  Result.Copies := Self.Copies;
  Result.Title := Self.Get_Title;
  Result.FileName := Self.Get_FileName;
  Result.Collate := Self.Get_Collate;

  // Копируем настройки принтера:
  Self.GetPrinter(l_Device, l_Driver, l_Port, l_hDeviceMode);
  Result.SetPrinter(l_Device, l_Driver, l_Port, CopyData(l_hDeviceMode));
//#UC END# *49BAA14602EC_4799D40F0004_impl*
end;//Tl3Printer.Clone

А вот так - работает:

function Tl3Printer.Clone: Il3Printer;
//#UC START# *49BAA14602EC_4799D40F0004_var*
var
 l_PrinterIndex : Integer;
 l_Device,
 l_Driver,
 l_Port        : Array[0..255] of Char;
 l_hDeviceMode : THandle;
//#UC END# *49BAA14602EC_4799D40F0004_var*
begin
//#UC START# *49BAA14602EC_4799D40F0004_impl*
  Result := nil;
  l_PrinterIndex := Self.PrinterIndex; // Если что-то с принтером, то лучше упадем уже здесь...
  Result := Make;
  Result.PrinterIndex := l_PrinterIndex;
  Result.Copies := Self.Copies;
  Result.Title := Self.Get_Title;
  Result.FileName := Self.Get_FileName;
  Result.Collate := Self.Get_Collate;

  // Копируем настройки принтера:
  Self.GetPrinter(l_Device, l_Driver, l_Port, l_hDeviceMode);
  Result.SetPrinter(l_Device, l_Driver, l_Port, 0);
  // - тут ЗА СЧЁТ нуля - настройки - ПЕРЕЧИТАЮТСЯ, а не СКОПИРУЮТСЯ.
//#UC END# *49BAA14602EC_4799D40F0004_impl*
end;//

Комментарий - "Если что-то с принтером, то лучше упадем уже здесь..." - тоже - "доставляет".

Но "с волками жить"...

#1170. Ссылка. Проектирование программного обеспечения

http://m.habrahabr.ru/company/edison/blog/267569/

#1169. Цитата из интернета. О наследовании

"Наследование реализации — вот где настоящий адъ. Возьмём, к примеру, наследование вторичноротых (например, человека) от первичноротых (например, мухи). В результате вызова унаследованного конструктора у вторичноротых на ранней стадии эмбриона формируется первичный рот. Дальше он небезопасно кастуется в анальное отверстие, а настоящий (вторичный) рот создаётся в другом месте. "