Patch title: Release 85 bulk changes
Abstract:
File: /pliant/language/type/set/each.pli
Key:
    Removed line
    Added line
# Copyright  Patrice Ossona de Mendez pom@ehess.fr
#
# 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.

module "/pliant/install/ring2.pli"


function find_function mod ident args argresult -> funlist
  arg Str ident ; arg Module mod
  arg List args ; arg Type argresult ; arg Link:List funlist
  var Int nb_arg nb_total
  funlist :> new List
  var Pointer:Function fi
  nb_arg := 0
  var Pointer:Arrow t :> args first
  while t<>null
    check entry_type:t=Type
    nb_arg += 1
    t :> args next t
  nb_total := nb_arg+(shunt argresult=Void 0 1)
  var Pointer:Arrow c :> mod first ident
  while c<>null
    if entry_type:c=Function
      fi :> c map Function
      if fi:nb_args=nb_arg and fi:nb_args_with_result=nb_total
        var CBool match := true
        var Pointer:Arrow t :> args first
        for (var Int i) 0 nb_arg-1
          match := match and (fi arg i):type=(t map Type)
          t :> args next t
        match := match and (nb_total=nb_arg or (fi arg nb_arg):type=argresult)
        if match
          funlist append c
    c :> mod next ident c
    

function is_null a -> c
  arg Address a ; arg CBool c
  c := a=null

meta each e
  if e:size<3 or not e:0:is_pure_ident
    return
  var Pointer:Expression filter :> null map Expression
  var CBool reversed := false
  var Int i := 2
  while i<e:size-1
    if e:i:ident="filter" and i+1<e:size-1
      filter :> e i+1
      i += 2
    eif e:i:ident="reversed"
      reversed := true
      i += 1
    else
      return
  e:1 compile ?
  var Pointer:Type set :> e:1:result:type real_data_type
  if not (e:1 cast set)
    return
  var Str cat := set category
  if cat<>"List" and cat<>"Array" and cat<>"Index" and cat<>"Dictionary"
    return
  var Pointer:Type key_type :> set key_type
  var Pointer:Type value_type :> set value_type
  var Link:Argument finished :> argument local CBool
  var Link:Argument item :> e local_variable e:0:ident pointerto:value_type
  var Link:Argument item :> e local_variable e:0 pointerto:value_type
  if not exists:item
    return
  if exists:filter and not (filter cast CBool)
    return
  e:(e:size-1) compile ?
  var Link:Argument cursor :> argument indirect value_type item 0
  var Link:Instruction next :> instruction the_function:'do nothing'
  var Link:Instruction end :> instruction the_function:'do nothing'
  var List lt
  lt append addressof:set
  var Pointer:Function first :> (find_function e:module (shunt reversed ". last" ". first") lt value_type):first map Function
  check exists:first
  lt append addressof:value_type
  var Pointer:Function gonext :> (find_function e:module (shunt reversed ". previous" ". next") lt value_type):first map Function
  check exists:gonext
  e suckup e:1
  e add (instruction first e:1:result cursor)
  e add (instruction (the_function is_null Address -> CBool) item finished)
  e add (instruction (the_function 'jump if' CBool) finished jump end)
  var Link:Instruction body :> instruction the_function:'do nothing'
  e add body
  if exists:filter
    e suckup filter
    e add (instruction (the_function 'jump if not' CBool) filter:result jump next)
  e suckup (e e:size-1)
  if exists:filter
    e add next
  e add (instruction gonext  e:1:result cursor cursor)
  e add (instruction (the_function is_null Address -> CBool) item finished)
  e add (instruction (the_function 'jump if not' CBool) finished jump body)
  e add end
  e set_void_result

export each