/pliant/language/basic/part.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  type PartProperty 
 20    field Str label 
 21    field CBool restart 
 22   
 23   
 24  meta part e 
 25    if e:size<or e:size>or e:0:ident="" 
 26      return 
 27    if e:size=and not (e:cast Str) 
 28      return 
 29    var Str label := e:0:ident 
 30    var Link:Expression body :> e:size-1 
 31    if body:ident<>"{}" 
 32      return 
 33    if e:size=3 
 34      var Link:Argument ar :> argument local ActionRecord 
 35      suckup e:1 
 36      add (instruction (the_function mt_action_push_record ActionRecord Str) ar e:1:result) 
 37    var Link:Instruction begin :> instruction (the_function 'do nothing') 
 38    add begin 
 39    var Link:Void :> new Void 
 40    e:module define "pliant part "+label addressof:v 
 41    body compile 
 42    e:module undefine "pliant part "+label addressof:v 
 43    suckup body 
 44    var Link:Instruction end :> instruction (the_function 'do nothing') 
 45    add end 
 46    if e:size=3 
 47      add (instruction (the_function mt_action_pull_record ActionRecord) ar) 
 48    var Pointer:Arrow :> e:instructions first 
 49    while c<>null 
 50      var Pointer:Instruction :> map Instruction 
 51      if (addressof i:jump)=(cast -Address) 
 52        var Pointer:PartProperty :> (i:properties first "pliant part"map PartProperty 
 53        if addressof:p<>null and (entry_type addressof:p)=PartProperty and p:label=label 
 54          if p:restart 
 55            jump :> begin 
 56          else 
 57            jump :> end 
 58      :> e:instructions next c 
 59    set_void_result  
 60   
 61   
 62  function leave_restart e restart 
 63    arg_rw Expression e ; arg CBool restart 
 64    if e:size<>or e:0:ident="" 
 65      return 
 66    var Pointer:Arrow :> e:module first "pliant part "+e:0:ident 
 67    if c=null 
 68      return 
 69    var Link:Instruction jump :> instruction (the_function 'jump anyway') 
 70    jump jump :> (cast -Address) map Instruction 
 71    var Link:PartProperty :> new PartProperty 
 72    label := e:ident 
 73    restart := restart 
 74    jump:properties insert "pliant part" true addressof:p 
 75    add jump 
 76    set_void_result   
 77   
 78  meta leave e 
 79    leave_restart false 
 80   
 81  meta restart e 
 82    leave_restart true 
 83   
 84   
 85  export part leave restart