#-----------------------------------------------------------------------------*
#
#  @file gtl_module.galgas
#
#  @section desc File description
#
#  GTL modules.
#
#  @section copyright Copyright
#
#  Goil OIL compiler, part of Trampoline RTOS
#
#  Trampoline is copyright (c) CNRS, University of Nantes,
#  Ecole Centrale de Nantes
#  Trampoline is protected by the French intellectual property law.
#
#  This software is distributed under the GNU Public Licence V2.
#  Check the LICENSE file in the root directory of Trampoline
#
#  $Date$
#  $Rev$
#  $Author$
#  $URL$
#
#-----------------------------------------------------------------------------*

list @gtlArgumentList
{
  @bool    typed
  @type    type
  @lstring name
}

#-----------------------------------------------------------------------------*
class @gtlExecutableEntity
{
  @location           where
  @lstring            name
  @gtlArgumentList    formalArguments
  @gtlInstructionList instructions
}

method @gtlExecutableEntity checkArguments
  ?let @location    fromLocation
  ?let @gtlDataList actualArguments
  !@gtlData         entityVariableMap
  !@bool            result
{
  result = true
  entityVariableMap = @gtlStruct.new {
    !fromLocation
    !emptylstring()
    !.emptyMap
  }
  
  if [formalArguments length] != [actualArguments length] then 
    error fromLocation : "calling "
      + if [self dynamicType] == `@gtlProcedure then
        "procedure '"
      else
        "function '"
      end
      + name + "' needs " + [formalArguments length] + " arguments"
  else
    # Check the arguments have the good type
    for () in formalArguments, () in actualArguments do
      if [data dynamicType] != type & typed then
        error [data location] : [type typeName] + " expected for " + name
        result = false
      else
        [!?entityVariableMap setStructField !name !data]
      end
    end
  end
}  

#-----------------------------------------------------------------------------*
class @gtlProcedure : @gtlExecutableEntity
{
}

method @gtlProcedure call
  ?!@gtlContext      context
  ?!@library         lib
  ?!@string          outputString
  ? let @location    fromLocation
  ? let @gtlDataList actualArguments
{
  [self checkArguments
    !fromLocation !actualArguments ?@gtlData vars ?let @bool ok]
  if ok then
    [instructions execute !?context !?vars !?lib !?outputString]
  else
    error fromLocation : "procedure call failed"
  end
}

#-----------------------------------------------------------------------------*
class @gtlFunction : @gtlExecutableEntity
{
  @lstring returnVariable
}

getter @gtlFunction call
  ?let @location    fromLocation
  ?    @gtlContext  context
  ?    @library     lib
  ?let @gtlDataList actualArguments
  ->@gtlData        result
{
  [self checkArguments
    !fromLocation !actualArguments ?@gtlData funcVariableMap ?let @bool ok]
  [!?funcVariableMap setStructField
    !returnVariable
    !@gtlUnconstructed.new{ ![returnVariable location] !emptylstring() }
  ]
  if ok then
    @string outputString = ""
    [instructions execute !?context !?funcVariableMap !?lib !?outputString]
    result = [funcVariableMap resultField !returnVariable]
  else
   error fromLocation : "function call failed" : result
  end
}

#-----------------------------------------------------------------------------*
class @gtlGetter : @gtlFunction
{
  @type targetType
}

getter @gtlGetter callGetter
  ?let @location     fromLocation
  ?    @gtlContext   context
  ?    @library      lib
  ?let @gtlData      target
  ?let @gtlDataList  actualArguments
  ->@gtlData         result
{
  [self checkArguments
    !fromLocation !actualArguments ?@gtlData getterVariableMap ?let @bool ok]
  [!?getterVariableMap setStructField
    !returnVariable
    !@gtlUnconstructed.new{ ![returnVariable location] !emptylstring() }
  ]
  if ok then
    [!?getterVariableMap setStructField
      !.new { !"self" !fromLocation }
      !target
    ]
    @string outputString = ""
    [instructions execute !?context !?getterVariableMap !?lib !?outputString]
    result = [getterVariableMap resultField !returnVariable]
  else
   error fromLocation : "getter call failed" : result
  end
}

getter @gtlGetter typedName
  ->@lstring result
{
  result = .new { ![targetType typeName]+[name string] !where }
}

#-----------------------------------------------------------------------------*
class @gtlSetter : @gtlExecutableEntity
{
  @type targetType
}

method @gtlSetter callSetter
  ?let @location     fromLocation
  ?    @gtlContext   context
  ?    @library      lib
  ?!   @gtlData      target
  ?let @gtlDataList  actualArguments
{
  [self checkArguments
    !fromLocation !actualArguments ?@gtlData setterVariableMap ?let @bool ok]
  if ok then
    let @lstring selfName = .new { !"self" !fromLocation }
    [!?setterVariableMap setStructField
      !selfName
      !target
    ]
    @string outputString = ""
    [instructions execute !?context !?setterVariableMap !?lib !?outputString]
    [setterVariableMap structField !selfName ?target ?*]
  else
   error fromLocation : "setter call failed"
  end
}

getter @gtlSetter typedName
  ->@lstring result
{
  result = .new { ![targetType typeName]+[name string] !where }
}

#-----------------------------------------------------------------------------*
map @gtlProcMap
{
  @gtlProcedure procedure
  insert put error message "a procedure named '%K' is already declared in %L"
  search get error message "there is no procedure named '%K'"
}

#-----------------------------------------------------------------------------*
map @gtlFuncMap
{
  @gtlFunction function
  insert put error message "a function named '%K' is already declared in %L"
  search get error message "there is no function named '%K'"
}

#-----------------------------------------------------------------------------*
map @gtlGetterMap
{
  @gtlGetter theGetter
  insert put error message "a getter named '%K' is already declared in %L"
  search get error message "there is no getter named '%K'"
}

#-----------------------------------------------------------------------------*
map @gtlSetterMap
{
  @gtlSetter theSetter
  insert put error message "a setter named '%K' is already declared in %L"
  search get error message "there is no setter named '%K'"
}

#-----------------------------------------------------------------------------*
class @gtlModule
{
  @lstring    name
  @gtlProcMap procedures
  @gtlFuncMap functions
}