Patch title: Release 85 bulk changes
Abstract:
File: /pliant/language/debug/error2.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

scope "/pliant/language/" "/pliant/install/"
module "/pliant/install/ring2.pli"


meta '?' e
  if e:size<>1
    return
  e:0 compile
  if error_notified
    return
  e suckup e:0
  var Link:Argument a :> argument local CBool
  e add (instruction (the_function error_notified -> CBool) a)
  e add (instruction (the_function 'jump if' CBool) a jump ((cast -1 Address) map Instruction))
  e set_result e:0:result e:0:access

operator '?' 518h 1000000000 0


function add src dest
  arg Str src ; arg_rw Str dest
  dest := dest+src

function clear dest
  arg_w Str dest
  dest := ""

meta comment e
  if e:size<2
    return
  for (var Int i) 0 e:size-2
    if not (e:i explicit_cast Str)
      return
  e:(e:size-1) compile ?
  var Link:Argument msg
  if e:size<>2
    msg :> argument local Str
    e add (instruction (the_function clear Str) msg)
    for (var Int i) 0 e:size-2
      e suckup e:i
      e add (instruction (the_function add Str Str) e:i:result msg)
  else
    e suckup e:0
    msg :> e:0 result
  var Link:Argument r :> argument local ActionRecord
  var Link:Instruction push :> (instruction (the_function action_push_record ActionRecord Str) r msg)
  var Link:Instruction pull :> instruction (the_function action_pull_record ActionRecord) r
  e suckup e:(e:size-1)
  e add_nested_instructions push pull
  e set_void_result


meta shy e
  if e:size<>1
    return
  e:0 compile ?
  var Link:Argument a :> argument local CBool
  var Pointer:Instruction end :> instruction (the_function 'do nothing')
  e add (instruction (the_function error_notified -> CBool) a)
  e add (instruction (the_function 'jump if' CBool) a jump end)
  e suckup e:0
  var List nesteds
  var Pointer:Arrow c :> e:instructions first
  while c<>null
    check entry_type:c=Instruction
    var Pointer:Instruction i :> c map Instruction
    var Pointer:Function f :> i function
    if (f:flags .and. function_flag_may_generate_error)<>0
      c :> e:instructions insert_after c addressof:(instruction (the_function error_notified -> CBool) a)
      if nesteds:first=null
        c :> e:instructions insert_after c addressof:(instruction (the_function 'jump if' CBool) a jump end)
      else
        var Pointer:Instruction continue :> instruction (the_function 'do nothing')
        c :> e:instructions insert_after c addressof:(instruction (the_function 'jump if not' CBool) a jump continue)
        var Pointer:Arrow c2 :> nesteds first
        while c2<>null
          var Pointer:Instruction i2 :> c2 map Instruction
          c :> e:instructions insert_after c (addressof duplicate:i2)
          c2 :> nesteds next c2
        c :> e:instructions insert_after c addressof:continue
    if (addressof i:nested_with)<>null
      nesteds append (addressof i:nested_with)
    var Pointer:Arrow c2 :> nesteds first
    while c2<>null
      if c=c2
        c2 :> nesteds remove c2
      else
        c2 :> nesteds next c2
    c :> e:instructions next c
  e add end
  e set_result e:0:result e:0:access


function error_clear_and_pull r
  arg_rw ErrorRecord r
  r id := error_id_noerror
  error_pull_record r

function pick_error_message r -> m
  arg ErrorRecord r ; arg_R Str m
  m :> r message

meta safe e
  var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
  if c=null or entry_type:c<>Function
    return
  var Link:Function current_function :> c map Function
  if e:size<1
    return
  e:0 compile ?
  e suckup e:0
  var Link:Argument r :> argument local ErrorRecord
  var Int i := 1
  while i<e:size
    if not e:i:is_pure_ident or i+1>=e:size
      return
    var Str id := e:i:ident
    if i=1
      var Link:Argument cond :> argument local CBool
      e add (instruction (the_function error_notified -> CBool) cond)
    var Link:Expression body
    var Link:Argument msg :> null map Argument
    if id="failure" and i+2<e:size and e:(i+1):is_pure_ident
      msg :> argument indirect Str (argument local Address) 0
      var Link:LocalVariable lv :> new LocalVariable
      lv name := e:(i+1):ident
      lv body :> msg
      lv access := access_read
      lv function :> current_function
      e define lv:name addressof:lv e:module
      body :> e i+2 ; i := i+3
    eif id="failure"
      body :> e i+1 ; i := i+2
    eif id="success"
      body :> e i+1 ; i := i+2
    else
      return
    body compile ?
    var Link:Instruction end :> instruction (the_function 'do nothing')
    if id="success"
      e add (instruction (the_function 'jump if' CBool) cond jump end)
      e suckup body
    else
      e add (instruction (the_function 'jump if not' CBool) cond jump end)
      if addressof:msg<>null
        e add (instruction (the_function pick_error_message ErrorRecord -> Str) r msg)
      var Link:Expression e2 :> new Expression
      e2 suckup body
      var Link:Argument r2 :> argument local ErrorRecord
      var Link:Instruction open2 :> instruction (the_function error_push_record ErrorRecord ErrorID) r2 (argument constant ErrorID error_filter_none)
      var Link:Instruction close2 :> instruction (the_function error_pull_record ErrorRecord) r2
      e2 add_nested_instructions open2 close2
      e suckup e2
    e add end
  var Link:Instruction open :> instruction (the_function error_push_record ErrorRecord ErrorID) r (argument constant ErrorID error_filter_all)
  var Link:Instruction close :> instruction (the_function error_clear_and_pull ErrorRecord) r
  e add_nested_instructions open close
  e set_void_result 

dual_keyword safe 1 3 success 1 1
dual_keyword safe 1 3 failure 1 2


export '?' comment shy safe