Только код. Определение аксиоматики моей скриптовой машины. На ней же

// Аксиоматика

IMMEDIATE OPERATOR ^L
 // - определяет ПРАВЫЙ параметр, который может быть как словом, так и неизвестным идентификатором
 //   L - сокращение типа от слова Literal
 //   При этом передаётся ссылка на ИСХОДНОЕ слово, а не на КОМПИЛИРОВАННУЮ последовательность.
 //   Это важно для ОПЕРАТОРОВ и WordWorker'ов.
 TtfwWordModifier::tfw_wmRightWordRef Ctx:IncludeModifier
 TtfwWordModifier::tfw_wmTreatUnknownAsString Ctx:IncludeModifier
; // ^L

IMMEDIATE OPERATOR BOOLEAN
 TtfwWordModifier::tfw_wmBool Ctx:IncludeModifier
; // BOOLEAN

IMMEDIATE OPERATOR CARDINAL
 TtfwWordModifier::tfw_wmInt Ctx:IncludeModifier
; // CARDINAL

IMMEDIATE OPERATOR INTEGER
 TtfwWordModifier::tfw_wmInt Ctx:IncludeModifier
; // INTEGER

IMMEDIATE OPERATOR STRING
 TtfwWordModifier::tfw_wmStr Ctx:IncludeModifier
; // STRING

IMMEDIATE OPERATOR ARRAY
 TtfwWordModifier::tfw_wmList Ctx:IncludeModifier
; // ARRAY

IMMEDIATE OPERATOR OBJECT
 TtfwWordModifier::tfw_wmObj Ctx:IncludeModifier
; // OBJECT

IMMEDIATE OPERATOR INTERFACE
 TtfwWordModifier::tfw_wmIntf Ctx:IncludeModifier
; // INTERFACE

IMMEDIATE OPERATOR CHAR
 TtfwWordModifier::tfw_wmChar Ctx:IncludeModifier
; // CHAR

IMMEDIATE OPERATOR CLASS
 TtfwWordModifier::tfw_wmClass Ctx:IncludeModifier
; // CLASS

INLINE OPERATOR then
  ^ IN aWhatToThen
 aWhatToThen DO
; // then

BOOLEAN FUNCTION NotValid IN %S
 if ( %S IsVoid ) then
  ( true >>> Result )
 else
 if ( %S pop:object:IsNil ) then
  ( true >>> Result )
 else 
  ( false >>> Result )
; // NotValid

BOOLEAN OPERATOR IS
  CLASS OBJECT IN anObj
  ^ IN aClass
 STRING CLASS VAR l_Class
 ( aClass DO ) >>> l_Class
 if ( anObj IsClass ) then
  ( ( l_Class anObj pop:class:Inherits ) >>> Result )
 else
  ( ( l_Class anObj pop:object:Inherits ) >>> Result )
; // IS

STRING FUNCTION |N

  /*OBJECT*/ IN %S

 if ( %S IsVoid ) then
  ( '' >>> Result )
 else
 if ( %S pop:object:IsNil ) then
  ( '' >>> Result )
 else
 if ( %S IS class::TkwString ) then
  ( %S DO >>> Result )
 else
 if ( %S IS class::TkwInteger ) then
  ( %S DO IntToStr >>> Result )
 else
 if ( %S IS class::TkwMain ) then
  ( %S pop:object:ClassName >>> Result )
 else
 if ( %S IS class::TkwCompiledMain ) then
  ( %S pop:object:ClassName >>> Result )
 else
  ( %S pop:Word:Name >>> Result )
; // |N

IMMEDIATE OPERATOR WordAlias
 ^L IN aName
 ^ LINK IN aCode
 aCode aName |N Define
; // WordAlias

NamedWordProducer %INHERITS %G
 // - список унаследованных элементов

WordAlias ITERATE Iterate
WordAlias WordWorker WORDWORKER

WordAlias operator OPERATOR

//   VOID operator :=
operator :=
// - пока так, иначе конструкция @ XXX -> A := 1024 - не работает, т.к. XXX снимается со стека уже в контексте := И срабатывает КОНТРОЛЬ СТЕКА   
  ^@ IN aLeft
  ^ IN aRight
 aRight DO >>>^ aLeft
;

VOID operator ^:=
  IN aLeft
  ^ IN aRight
 aRight DO >>>^ aLeft
;

VOID operator >>>[]
  IN aLeft
  ^ IN aRight
 aLeft aRight DO Array:Add
;

operator IT 
  ARRAY IN A
  ^ IN aWhatToDo
 aWhatToDo A ITERATE
; // IT

WordAlias ==> IT

operator for
  ^ IN aList
  ^ IN aWhatToDo
 aList DO ==> ( aWhatToDo DO )
; // for

WordAlias CONSTANT CONST
WordAlias Test PROCEDURE
WordAlias Тест PROCEDURE

WordAlias Если if
WordAlias если if
WordAlias то then
WordAlias иначе else

WordAlias выходим EXIT
WordAlias Выходим EXIT

WordAlias =:^ >>>^
WordAlias =: >>>

VOID operator +!
  INTEGER IN anIncrement
  ^ IN aWhatToIncrement
// Пример:
// {code}
// VAR l_WinID
// 5 >>> l_WinID
// 1 +! l_WinID
// l_WinID .
// {code}

 aWhatToIncrement DO anIncrement + =:^ aWhatToIncrement
; // +!

WordAlias =+ +!

VOID operator =- 
  INTEGER IN anInc
  ^ IN aWhatToDecrement
 aWhatToDecrement DO anInc - =:^ aWhatToDecrement
; // =-

VOID operator +=
  ^@ IN aLeft
  ^ IN aRight
 aLeft DO
 aRight DO
 +
 >>>^ aLeft
;

VOID operator -=
  ^@ IN aLeft
  ^ IN aRight
 aLeft DO
 aRight DO
 -
 >>>^ aLeft
;

STRING FUNCTION strings:Cat ARRAY IN anArray
 // - складывает строки массива на стеке

 PROCEDURE DoCat STRING IN aStr1
  Result := ( Result aStr1 Cat )
 ; // DoCat

 Result := ''
 @ DoCat anArray ITERATE
; // strings:Cat

VOID operator INC
  ^ IN aWhatToIncrement
 aWhatToIncrement DO 1 + =:^ aWhatToIncrement
; // INC

WordAlias ++! INC
WordAlias Inc INC

VOID operator DEC
  ^ IN aWhatToDecrement
 aWhatToDecrement DO 1 - =:^ aWhatToDecrement
; // DEC

WordAlias --! DEC
WordAlias Dec DEC

BOOLEAN FUNCTION array:HasString ARRAY IN anArray STRING IN aString
 Result := false

  PROCEDURE Поиск STRING IN anItem
   if ( anItem aString SameStr )
    ( Result := true )
  ; // Поиск

  @ Поиск anArray ITERATE
; // array:HasString

BOOLEAN FUNCTION array:HasText ARRAY IN anArray STRING IN aString
 Result := false

  PROCEDURE Поиск STRING IN anItem
   if ( anItem aString SameText )
    ( Result := true )
  ; // Поиск

  @ Поиск anArray ITERATE
; // array:HasText

INTEGER FUNCTION array:StringCount ARRAY IN anArray STRING IN aString
 Result := 0

  PROCEDURE Поиск STRING IN anItem
   if ( anItem aString SameStr )
    ( ++! Result )
  ; // Поиск

  @ Поиск anArray ITERATE
; // array:StringCount

PROCEDURE "Сравнить текущее исключение с эталоном"
 STRING VAR l_ClassName
 current:exception:ClassName >>> l_ClassName
 l_ClassName .
 STRING VAR l_Message
 STRING VAR l_Message_out
 current:exception:Message >>> l_Message

 if ( l_ClassName 'EAssertionFailed' SameText )
  ( l_Message '(' string:Split DROP >>> l_Message )
 else
  ( l_ClassName 'EAccessViolation' SameText ? (
     l_Message ' at ' string:Split DROP >>> l_Message
    )
  )
 l_Message 'Главный файл:' string:Split =: l_Message_out =: l_Message
 l_Message_out '. ' string:Split =: l_Message_out DROP
 l_Message l_Message_out Cat .
; // "Сравнить текущее исключение с эталоном"

PROCEDURE "Выполнить и если было исключение, то выполнить" IN aProc1 IN aProc2
 INTEGER VAR l_StackLevel
 l_StackLevel := StackLevel
 TRY
  TRY
   aProc1 DO
  EXCEPT
   "Сравнить текущее исключение с эталоном"
   aProc2 DO
  END
 FINALLY
  l_StackLevel ReduceStackLevel
 END
; // "Выполнить и если было исключение, то выполнить"

VOID operator анти-тест
  ^ IN aWhatToDo
 VAR l_WasException
 false =: l_WasException
 "Выполнить {(@ ( aWhatToDo DO ) )} и если было исключение, то выполнить {(@ ( true =: l_WasException ) )}"
 l_WasException
  [ 'Тест ' script:FileName ' почему-то стал проходить' ] strings:Cat
   ASSERTS
; // анти-тест

WordAlias "тест с падением" анти-тест

VOID operator "Выполнить подавив исключение"
  ^ IN aWhatToDo
 VAR l_WasException
 false =: l_WasException
 "Выполнить {(@ ( aWhatToDo DO ) )} и если было исключение, то выполнить {(@ ( true =: l_WasException ) )}"
 l_WasException
  [ 'Запланированного исключения в тесте: ' script:FileName ' почему-то не случилось' ] strings:Cat
   ASSERTS
; // "Выполнить подавив исключение"

PROCEDURE "Выполнить обработав исключение" OBJECT IN aProc STRING IN anException
 TRY
  aProc DO
 EXCEPT
  current:exception:Message anException ?!= ? RAISE
 END
; // "Выполнить обработав исключение"

PROCEDURE ToDo STRING IN aString
 'To Do: ' aString Cat .
; // ToDo

PROCEDURE "! Тест в разработке"
 script:FileName sysutils:ExtractFileName ' в состоянии разработки' Cat ToDo
; // "! Тест в разработке"

PROCEDURE OnTest
// - ждёт обновления контролов по OnTest
  3 LOOP (
   ProcessMessages
   application:ActionIdle
  )
  // - позволяем пройти всем OnTest
; // OnTest

WordAlias "Дать системе перерисоваться" OnTest

PROCEDURE "Нажать" STRING IN aString
 aString key
 OnTest
; // "Нажать"

VOID operator "Обработать Enter модально"
  ^ IN aWhatToDo
 @ ( "Нажать {('Enter')}" ) MODAL ( aWhatToDo DO )
; // "Обработать Enter модально"

PROCEDURE ASSUME STRING IN aStr
 // Включает "условную директиву" aStr в тестируемом приложении
 // http://mdp.garant.ru/pages/viewpage.action?pageId=236719181 №44
; // ASSUME

PROCEDURE UNASSUME STRING IN aStr
 // Выключает "условную директиву" aStr в тестируемом приложении
 // http://mdp.garant.ru/pages/viewpage.action?pageId=236719181 №44
; // UNASSUME

BOOLEAN FUNCTION ArraysAreEqual ARRAY IN A ARRAY IN B
 A IsArray 'Где массив?' ASSERTS
 B IsArray 'Где массив?' ASSERTS
 CONST l_Exception 'Выходим из итератора'
 INTEGER VAR l_Index
 l_Index := 0
 INTEGER VAR l_Count
 l_Count := ( A Array:Count )

   PROCEDURE DoWithItem IN B[i]
    if ( l_Index A [i] B[i] ?== ) then
     ++! l_Index
    else
    (
     Result := false
     l_Exception RAISE
    )
   ;

 if ( l_Count B Array:Count ?!= ) then
 (
  Result := false
  EXIT
 )
 TRY
  @ DoWithItem B ITERATE
  Result := true
 EXCEPT
  if ( current:exception:Message l_Exception ?!= ) then
   RAISE
 END
; // ArraysAreEqual

BOOLEAN operator AND BOOLEAN
  IN aFirst
  ^ IN aSecond
 // Двусторонний, а не обратный польский &&
 if aFirst then
  (
   if ( aSecond DO ) then
    ( Result := true )
   else
    ( Result := false )
   )
 else
  ( Result := false )
; // AND

WordAlias И AND

BOOLEAN operator OR BOOLEAN
  IN aFirst
  ^ IN aSecond
 // Двусторонний, а не обратный польский ||
 if aFirst then
  ( Result := true )
 else
  if ( aSecond DO ) then
   ( Result := true )
  else
   ( Result := false )
; // OR

WordAlias ИЛИ OR

BOOLEAN operator NOT
  ^ IN aWhatToNot
 // Правосторонний, а не обратный польский !
 Result := ( aWhatToNot DO ! )
; // NOT

WordAlias НЕ NOT

BOOLEAN operator =
  IN aLeft
  ^ IN aRight
 // Правосторонний, а не обратный польский ==
 // ТЕПЕРЬ С БЛЭКДЖЕКОМ И МАССИВАМИ!

//1 РАВНО 1  . - True
//[ 10 20 ] РАВНО ( 10 20 ) . - True
//[ 10 20 ] РАВНО ( [ 10 20 ] ) . - True
//[ 10 ] РАВНО ( [ 10 ] ) . - True
//[ 10 ] РАВНО ( 10 ) . - True
//[ 10 ] РАВНО ( 20 ) . - False

 ARRAY VAR l_Right
 l_Right := ( [ aRight DO ] )
 TRY
  if ( aLeft IsArray ) then
  (
   if
    (
     ( l_Right IsArray ) И
     ( l_Right Array:Count 1 == ) И
     ( 0 l_Right [i] IsArray )
    )
   then
   (
    Result := ( aLeft 0 l_Right [i] ArraysAreEqual )
   )
   else
   (
    Result := ( aLeft l_Right ArraysAreEqual )
   )
  )
  else
  (
   if ( l_Right Array:Count 1 == ) then
   (
    Result := ( aLeft 0 l_Right [i] ?== )
   )
   else
   (
    Result := false
   )
  )
 FINALLY
  l_Right := ( [ ] )
  aLeft := nil
 END
; //=

WordAlias РАВНО =

BOOLEAN operator <>
  IN aLeft
  ^ IN aRight
 // Правосторонний, а не обратный польский !=
 Result := ( aLeft aRight DO ?!= )
; //<>

WordAlias НЕРАВНО <>
WordAlias "НЕ РАВНО" НЕРАВНО

BOOLEAN operator >
  STRING INTEGER BOOLEAN IN aLeft
  ^ IN aRight
 Result := ( aLeft aRight DO GREATER )
;

WordAlias БОЛЬШЕ >

BOOLEAN operator <
  STRING INTEGER BOOLEAN IN aLeft
  ^ IN aRight
  Result := ( aLeft aRight DO LESS )
;

WordAlias МЕНЬШЕ <

BOOLEAN operator >=
  STRING INTEGER BOOLEAN IN aLeft
  ^ IN aRight
 Result := ( aLeft < ( aRight DO ) ! )
;

WordAlias "БОЛЬШЕ ИЛИ РАВНО" >=

BOOLEAN operator <=
  STRING INTEGER BOOLEAN IN aLeft
  ^ IN aRight
 Result := ( aLeft > ( aRight DO ) ! )
;

WordAlias "МЕНЬШЕ ИЛИ РАВНО" <=

WordAlias ЯВЛЯЕТСЯ IS
WordAlias Is IS

BOOLEAN operator NOTIS
  CLASS OBJECT IN anObj
  ^ IN aClass
 Result := NOT ( anObj Is ( aClass DO ) )
;

WordAlias NotIs NOTIS
WordAlias НЕЯВЛЯЕТСЯ NOTIS
WordAlias "НЕ ЯВЛЯЕТСЯ" НЕЯВЛЯЕТСЯ

IMMEDIATE operator WordAliasByRef
 ^L IN aName
 ^ IN aCode
 aCode DO aName |N Define
; // WordAliasByRef

IMMEDIATE operator [EXECUTE]
 ^ IN aCode
 aCode DO
; // [EXECUTE] 
 
STRING operator |NS
 IN aName
 Result := ( [ '`' aName |N '`' ] strings:Cat )
; // |NS

OBJECT FUNCTION %ST IN %S
 if ( %S NotValid ) then
 (
  Result := nil
 ) 
 else
 (
  Result := ( %S pop:Word:Producer )
 ) 
; // %ST

STRING FUNCTION |S IN %S
 %S %ST |N =: Result
; // |S

OBJECT FUNCTION %P IN %S
 VAR l_P
 l_P := ( %S pop:Word:Parent )
 if ( l_P pop:Word:Name '%C' SameText ) then
 ( 
  l_P := ( l_P pop:Word:Parent )
 ) 
 if ( l_P NotValid ) then
 (
  Result := nil
 ) 
 else
 (
  Result := l_P
 ) 
; // %P

OBJECT FUNCTION %T IN %S
 VAR l_T
 l_T := ( %S ->^ '%T' )
 if ( l_T NotValid ) then
 (
  Result := nil
 ) 
 else
 (
  l_T := ( l_T DO )
  if ( l_T NotValid ) then
  (
   Result := nil
  ) 
  else
  (
   Result := l_T
  )
 )
; // %T

STRING FUNCTION %TN IN %S
 Result := ( %S %T |N )
; // %TN

STRING FUNCTION %TS IN %S
 Result := ( %S %T |S )
; // %TS

STRING FUNCTION |U IN %S
 VAR l_U
 l_U := ( %S ->^ '%U' )
 if ( l_U NotValid ) then
 (
  Result := ''
 ) 
 else
 (
  Result := ( l_U DO |N )
 )
; // |U

operator WHILE
  ^ IN aCondition
  ^ IN aWhatToDo
 @ ( aCondition DO ) WHILEDO ( aWhatToDo DO )
; // WHILE

WordAlias ПОКА WHILE
WordAlias while WHILE

WordAlias ДА true

WordAlias НЕТ false

BOOLEAN operator "в интервале"
  INTEGER IN aValue
  ^ IN anInterval
 INTEGER VAR "нижнее значение"
 INTEGER VAR "верхнее значение"
 ( anInterval DO )
 >>> "верхнее значение"
 >>> "нижнее значение"
 Result := ( ( aValue "БОЛЬШЕ ИЛИ РАВНО" "нижнее значение" )
 И ( aValue "МЕНЬШЕ ИЛИ РАВНО" "верхнее значение" ) )
; // "в интервале"
   
ARRAY FUNCTION SplitToArray
 STRING IN aValue
 STRING IN aDelim
 STRING VAR l_Tail
 aValue >>> l_Tail
 if ( l_Tail = '' ) then
 BEGIN
  Result := [ '' ]
 END 
 else
 BEGIN 
  Result := [ 
   WHILE ( l_Tail <> '' )
   BEGIN
    l_Tail aDelim string:Split >>> l_Tail
   END
  ]
 END
; // SplitToArray

IMMEDIATE operator __INIT_VAR
 IN aValue
 ^ IN aVar
 aValue >>>^ aVar
; // __INIT_VAR

PROCEDURE Ctx:Parser:PushSymbols
 STRING IN aString
 aString ' ' SplitToArray ==> ( 
  STRING IN aStr
  if ( '`' aStr StartsStr ) then
  BEGIN
   aStr '`' '' string:Replace Ctx:Parser:PushString
  END
  else
  BEGIN
   aStr Ctx:Parser:PushSymbol 
  END
 )
; // Ctx:ParserPushSymbols

PROCEDURE Ctx:Parser:PushArray
 ARRAY IN anArray
 anArray ==> Ctx:Parser:PushSymbols
; // Ctx:Parser:PushArray

IMMEDIATE operator VarProducer
 // - Переносим VarProducer из Delphi в скрипты
 //   Единственное пока отличие, что стереотипы были VarProducer VarType,
 //   а стало ??? Unexisting word ??? VAR
 //   Но со временем можно ввести SetStereotype (WordProducer)
  ^L IN aName
 STRING VAR l_Name
 aName |N >>> l_Name

 [
 'IMMEDIATE operator'
 l_Name

 '@ VAR DO'
 ';' 
 ] Ctx:Parser:PushArray
; // VarProducer

// Код в VarProducer в итоге заставляет машину скомпилировать следующее:
/* 
IMMEDIATE operator VarType
 @ VAR DO
;
*/

IMMEDIATE operator InitedVarProducer
  ^L IN aName
 STRING VAR l_Name
 aName |N >>> l_Name
 
 [
 'IMMEDIATE operator'
 l_Name
 
 '^L IN aName'
 '^ IN aValue'
 'STRING VAR l_Name'
 'aName |N >>> l_Name'
 
 '`VAR` Ctx:Parser:PushSymbol'
 'l_Name Ctx:Parser:PushSymbol'
 
 'aValue DO'
 '`__INIT_VAR` Ctx:Parser:PushSymbol'
 
 'l_Name Ctx:Parser:PushSymbol'
 ';' 
 ] Ctx:Parser:PushArray
; // InitedVarProducer

// Код в InitedVarProducer в итоге заставляет машину скомпилировать следующее:'
/*
IMMEDIATE operator VarTypeI
  ^L IN aName
  ^ IN aValue
 STRING VAR l_Name
 aName |N >>> l_Name
 
 'VAR' Ctx:Parser:PushSymbol
 l_Name Ctx:Parser:PushSymbol
 
 aValue DO
 '__INIT_VAR' Ctx:Parser:PushSymbol
 
 l_Name Ctx:Parser:PushSymbol
 
; // VarTypeI
*/

operator AllMembers==>
// Итерирует все вложенные элементы рекурсивно
 OBJECT IN anObject
 ^ IN aLambda
 
 FORWARD DoMembers
 
 PROCEDURE DoMembers
  OBJECT IN anObject
  anObject MembersIterator ==> (
   IN aWord 
   aWord aLambda DO
   aWord DoMembers
  )
 ; // DoMembers
 
 anObject DoMembers
; // AllMembers==>

STRING FUNCTION strings:CatSep 
 // - складывает строки массива
  ARRAY IN anArray
  STRING IN aSep

 PROCEDURE DoCat 
  STRING IN aStr
  
  if ( aStr <> '' ) then
  BEGIN
   if ( Result = '') then
    ( Result := aStr )
   else
    (
     if ( aSep Result EndsStr ) then
      (
       Result := ( Result aStr Cat )
      )
     else
      (
       Result := ( Result aSep Cat aStr Cat )
      ) 
    )
  END // aStr <> ''
 ; // DoCat

 Result := ''
 @ DoCat anArray ITERATE
; // strings:Cat

PROCEDURE __DumpMembers
 OBJECT IN anObject
 
 PROCEDURE Dump
  OBJECT IN anObject
   [
    anObject pop:Word:Directives
    anObject %ST %ST |N
    anObject %ST |N
    anObject |N
   ] ' ' strings:CatSep .
 ; // Dump
 
 anObject Dump
 anObject AllMembers==> Dump
 anObject %P Dump
; // __DumpMembers

operator Ctx:Parser:PushSymbolAtRight
 ^L IN aName 
 aName |N Ctx:Parser:PushSymbol
; // Ctx:Parser:PushSymbolAtRight

IMMEDIATE operator NamedInitedVarProducer
  ^L IN aName
  ^L IN aNewName
  
 STRING VAR l_Name
 aName |N >>> l_Name
 
 STRING VAR l_NewName
 aNewName |N >>> l_NewName
 
 [
 'IMMEDIATE operator'
 l_Name
 
 '^ IN aValue'
 
 '`VAR` Ctx:Parser:PushSymbol'
 
 'Ctx:Parser:PushSymbolAtRight'
 l_NewName
 
 'aValue DO'
 '`__INIT_VAR` Ctx:Parser:PushSymbol'
 
 'Ctx:Parser:PushSymbolAtRight'
 l_NewName
 
 ';' 
 ] Ctx:Parser:PushArray
; // NamedInitedVarProducer

IMMEDIATE operator NamedAutolinkProducer
 ^L IN aOpName
 ^L IN aName
 [
  'IMMEDIATE operator'
  aOpName |N
  '^ IN aCode'
  'aCode '
  aName |NS
  'Define'
  ';' 
 ] Ctx:Parser:PushArray
; // NamedAutolinkProducer