/pliant/language/type/set/each.pli
 
 1  # Copyright  Patrice Ossona de Mendez pom@ehess.fr 
 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  module "/pliant/install/ring2.pli" 
 17   
 18   
 19  function find_function mod ident args argresult -> funlist 
 20    arg Str ident ; arg Module mod 
 21    arg List args ; arg Type argresult ; arg Link:List funlist 
 22    var Int nb_arg nb_total 
 23    funlist :> new List 
 24    var Pointer:Function fi 
 25    nb_arg := 0 
 26    var Pointer:Arrow :> args first 
 27    while t<>null 
 28      check entry_type:t=Type 
 29      nb_arg += 1 
 30      :> args next t 
 31    nb_total := nb_arg+(shunt argresult=Void 0 1) 
 32    var Pointer:Arrow :> mod first ident 
 33    while c<>null 
 34      if entry_type:c=Function 
 35        fi :> map Function 
 36        if fi:nb_args=nb_arg and fi:nb_args_with_result=nb_total 
 37          var CBool match := true 
 38          var Pointer:Arrow :> args first 
 39          for (var Int i) nb_arg-1 
 40            match := match and (fi arg i):type=(map Type) 
 41            :> args next t 
 42          match := match and (nb_total=nb_arg or (fi arg nb_arg):type=argresult) 
 43          if match 
 44            funlist append c 
 45      :> mod next ident c 
 46       
 47   
 48  function is_null a -> c 
 49    arg Address a ; arg CBool c 
 50    := a=null 
 51   
 52  meta each e 
 53    if e:size<or not e:0:is_pure_ident 
 54      return 
 55    var Pointer:Expression filter :> null map Expression 
 56    var CBool reversed := false 
 57    var Int := 2 
 58    while i<e:size-1 
 59      if e:i:ident="filter" and i+1<e:size-1 
 60        filter :> i+1 
 61        += 2 
 62      eif e:i:ident="reversed" 
 63        reversed := true 
 64        += 1 
 65      else 
 66        return 
 67    e:compile ? 
 68    var Pointer:Type set :> e:1:result:type real_data_type 
 69    if not (e:cast set) 
 70      return 
 71    var Str cat := set category 
 72    if cat<>"List" and cat<>"Array" and cat<>"Index" and cat<>"Dictionary" 
 73      return 
 74    var Pointer:Type key_type :> set key_type 
 75    var Pointer:Type value_type :> set value_type 
 76    var Link:Argument finished :> argument local CBool 
 77    var Link:Argument item :> local_variable e:pointerto:value_type 
 78    if not exists:item 
 79      return 
 80    if exists:filter and not (filter cast CBool) 
 81      return 
 82    e:(e:size-1) compile ? 
 83    var Link:Argument cursor :> argument indirect value_type item 0 
 84    var Link:Instruction next :> instruction the_function:'do nothing' 
 85    var Link:Instruction end :> instruction the_function:'do nothing' 
 86    var List lt 
 87    lt append addressof:set 
 88    var Pointer:Function first :> (find_function e:module (shunt reversed ". last" ". first"lt value_type):first map Function 
 89    check exists:first 
 90    lt append addressof:value_type 
 91    var Pointer:Function gonext :> (find_function e:module (shunt reversed ". previous" ". next"lt value_type):first map Function 
 92    check exists:gonext 
 93    suckup e:1 
 94    add (instruction first e:1:result cursor) 
 95    add (instruction (the_function is_null Address -> CBool) item finished) 
 96    add (instruction (the_function 'jump if' CBool) finished jump end) 
 97    var Link:Instruction body :> instruction the_function:'do nothing' 
 98    add body 
 99    if exists:filter 
 100      suckup filter 
 101      add (instruction (the_function 'jump if not' CBool) filter:result jump next) 
 102    suckup (e:size-1) 
 103    if exists:filter 
 104      add next 
 105    add (instruction gonext  e:1:result cursor cursor) 
 106    add (instruction (the_function is_null Address -> CBool) item finished) 
 107    add (instruction (the_function 'jump if not' CBool) finished jump body) 
 108    add end 
 109    set_void_result 
 110   
 111  export each