/pliant/language/type/misc/status.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  scope "/pliant/language/" "/pliant/install/" 
 17  module "/pliant/install/ring2.pli" 
 18   
 19   
 20  type Status 
 21    field CBool wrong 
 22   
 23  type ExtendedStatus 
 24    field CBool wrong 
 25    field Str message 
 26   
 27   
 28  constant success { gvar Status temp ; temp wrong := false ; temp } 
 29  constant failure { temp wrong := true ; temp } 
 30  # there is a potential big bug there: if you put the instructions 
 31  # the other way round, such as 
 32  #   var Status temp ; temp wrong := false ; constant success temp  
 33  # the system will not work properly because when 
 34  # the constants are evaluated, the temp variable as not been set, 
 35  # because the 'constant' meta will evaluate at compile time whereas 
 36  # 'tmp wrong := ...' will be executed at run time. 
 37   
 38  function failure m -> es 
 39    arg Str m ; arg ExtendedStatus es 
 40    es wrong := true 
 41    es message := m 
 42   
 43   
 44  function 'cast ExtendedStatus' s -> es 
 45    arg Status s ; arg ExtendedStatus es 
 46    extension 
 47    es wrong := wrong 
 48    es message := "" 
 49   
 50  function 'cast Status' es -> s 
 51    arg ExtendedStatus es ; arg Status s 
 52    reduction 
 53    wrong := es wrong 
 54   
 55   
 56  function compare a b -> c 
 57    arg Status b ; arg Int c 
 58    := compare a:wrong b:wrong 
 59   
 60  method e uncasted_type -> t 
 61    arg Expression e ; arg_R Type t 
 62    if (addressof e:uncasted_result)<>null 
 63      :> e:uncasted_result type 
 64    else 
 65      :> e:result type 
 66     
 67  meta compare e 
 68    always_strong_definition 
 69    if e:size<>2 
 70      return 
 71    e:compile 
 72    if error_notified 
 73      return 
 74    e:compile 
 75    if error_notified 
 76      return 
 77    if e:0:uncasted_type=Status or e:0:uncasted_type=ExtendedStatus or e:1:uncasted_type=Status or e:1:uncasted_type=ExtendedStatus 
 78      if e:0:uncasted_type<>Status or e:1:uncasted_type<>Status 
 79        if (e:explicit_cast Status) and (e:explicit_cast Status) 
 80          var Link:Argument :> argument local Int 
 81          suckup e:0 ; suckup e:1 
 82          add (instruction (the_function compare Status Status -> Int) e:0:result e:1:result a) 
 83          set_result access_read 
 84   
 85   
 86  constant defined success 
 87  constant undefined failure 
 88   
 89  export Status success failure compare defined undefined 
 90  export ExtendedStatus '. message' 'cast Status' 'cast ExtendedStatus'