/pliant/language/debug/error2.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  meta '?' e 
 21    if e:size<>1 
 22      return 
 23    e:compile 
 24    if error_notified 
 25      return 
 26    suckup e:0 
 27    var Link:Argument :> argument local CBool 
 28    add (instruction (the_function error_notified -> CBool) a) 
 29    add (instruction (the_function 'jump if' CBool) jump ((cast -Address) map Instruction)) 
 30    set_result e:0:result e:0:access 
 31   
 32  operator '?' 518h 1000000000 0 
 33   
 34   
 35  function add src dest 
 36    arg Str src ; arg_rw Str dest 
 37    dest := dest+src 
 38   
 39  function clear dest 
 40    arg_w Str dest 
 41    dest := "" 
 42   
 43  meta comment e 
 44    if e:size<2 
 45      return 
 46    for (var Int i) e:size-2 
 47      if not (e:explicit_cast Str) 
 48        return 
 49    e:(e:size-1) compile ? 
 50    var Link:Argument msg 
 51    if e:size<>2 
 52      msg :> argument local Str 
 53      add (instruction (the_function clear Str) msg) 
 54      for (var Int i) e:size-2 
 55        suckup e:i 
 56        add (instruction (the_function add Str Str) e:i:result msg) 
 57    else 
 58      suckup e:0 
 59      msg :> e:result 
 60    var Link:Argument :> argument local ActionRecord 
 61    var Link:Instruction push :> (instruction (the_function action_push_record ActionRecord Str) msg) 
 62    var Link:Instruction pull :> instruction (the_function action_pull_record ActionRecord) r 
 63    suckup e:(e:size-1) 
 64    add_nested_instructions push pull 
 65    set_void_result 
 66   
 67   
 68  meta shy e 
 69    if e:size<>1 
 70      return 
 71    e:compile ? 
 72    var Link:Argument :> argument local CBool 
 73    var Pointer:Instruction end :> instruction (the_function 'do nothing') 
 74    add (instruction (the_function error_notified -> CBool) a) 
 75    add (instruction (the_function 'jump if' CBool) jump end) 
 76    suckup e:0 
 77    var List nesteds 
 78    var Pointer:Arrow :> e:instructions first 
 79    while c<>null 
 80      check entry_type:c=Instruction 
 81      var Pointer:Instruction :> map Instruction 
 82      var Pointer:Function :> function 
 83      if (f:flags .and. function_flag_may_generate_error)<>0 
 84        :> e:instructions insert_after addressof:(instruction (the_function error_notified -> CBool) a) 
 85        if nesteds:first=null 
 86          :> e:instructions insert_after addressof:(instruction (the_function 'jump if' CBool) jump end) 
 87        else 
 88          var Pointer:Instruction continue :> instruction (the_function 'do nothing') 
 89          :> e:instructions insert_after addressof:(instruction (the_function 'jump if not' CBool) jump continue) 
 90          var Pointer:Arrow c2 :> nesteds first 
 91          while c2<>null 
 92            var Pointer:Instruction i2 :> c2 map Instruction 
 93            :> e:instructions insert_after c (addressof duplicate:i2) 
 94            c2 :> nesteds next c2 
 95          :> e:instructions insert_after addressof:continue 
 96      if (addressof i:nested_with)<>null 
 97        nesteds append (addressof i:nested_with) 
 98      var Pointer:Arrow c2 :> nesteds first 
 99      while c2<>null 
 100        if c=c2 
 101          c2 :> nesteds remove c2 
 102        else 
 103          c2 :> nesteds next c2 
 104      :> e:instructions next c 
 105    add end 
 106    set_result e:0:result e:0:access 
 107   
 108   
 109  function error_clear_and_pull r 
 110    arg_rw ErrorRecord r 
 111    id := error_id_noerror 
 112    error_pull_record r 
 113   
 114  function pick_error_message r -> m 
 115    arg ErrorRecord r ; arg_R Str m 
 116    :> message 
 117   
 118  meta safe e 
 119    var Pointer:Arrow :> pliant_general_dictionary first "pliant function" 
 120    if c=null or entry_type:c<>Function 
 121      return 
 122    var Link:Function current_function :> map Function 
 123    if e:size<1 
 124      return 
 125    e:compile ? 
 126    suckup e:0 
 127    var Link:Argument :> argument local ErrorRecord 
 128    var Int := 1 
 129    while i<e:size 
 130      if not e:i:is_pure_ident or i+1>=e:size 
 131        return 
 132      var Str id := e:i:ident 
 133      if i=1 
 134        var Link:Argument cond :> argument local CBool 
 135        add (instruction (the_function error_notified -> CBool) cond) 
 136      var Link:Expression body 
 137      var Link:Argument msg :> null map Argument 
 138      if id="failure" and i+2<e:size and e:(i+1):is_pure_ident 
 139        msg :> argument indirect Str (argument local Address) 0 
 140        var Link:LocalVariable lv :> new LocalVariable 
 141        lv name := e:(i+1):ident 
 142        lv body :> msg 
 143        lv access := access_read 
 144        lv function :> current_function 
 145        define lv:name addressof:lv e:module 
 146        body :> i+2 ; := i+3 
 147      eif id="failure" 
 148        body :> i+1 ; := i+2 
 149      eif id="success" 
 150        body :> i+1 ; := i+2 
 151      else 
 152        return 
 153      body compile ? 
 154      var Link:Instruction end :> instruction (the_function 'do nothing') 
 155      if id="success" 
 156        add (instruction (the_function 'jump if' CBool) cond jump end) 
 157        suckup body 
 158      else 
 159        add (instruction (the_function 'jump if not' CBool) cond jump end) 
 160        if addressof:msg<>null 
 161          add (instruction (the_function pick_error_message ErrorRecord -> Str) msg) 
 162        var Link:Expression e2 :> new Expression 
 163        e2 suckup body 
 164        var Link:Argument r2 :> argument local ErrorRecord 
 165        var Link:Instruction open2 :> instruction (the_function error_push_record ErrorRecord ErrorID) r2 (argument constant ErrorID error_filter_none) 
 166        var Link:Instruction close2 :> instruction (the_function error_pull_record ErrorRecord) r2 
 167        e2 add_nested_instructions open2 close2 
 168        suckup e2 
 169      add end 
 170    var Link:Instruction open :> instruction (the_function error_push_record ErrorRecord ErrorID) r (argument constant ErrorID error_filter_all) 
 171    var Link:Instruction close :> instruction (the_function error_clear_and_pull ErrorRecord) r 
 172    add_nested_instructions open close 
 173    set_void_result  
 174   
 175  dual_keyword safe 1 3 success 1 1 
 176  dual_keyword safe 1 3 failure 1 2 
 177   
 178   
 179  export '?' comment shy safe