Patch title: Release 85 bulk changes
Abstract:
File: /pliant/language/basic/control.c
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.

/*
abstract
  [The basic Pliant controls: (), {}, constant, var, if, while, for, addressof ...]
*/

/*
doc
  ['()' operator]
*/

FUNCTION Void instr_meta(struct Expression *e) {
  struct Expression *e0,*remain; Int i;
  if(e->arguments.nb==0) {
    Expression_set_void_result(e);
    return; }
  e0=EARG(e,0);
  Expression_compile(e0);
  if(error_notified())
    return;
  remain=entry_new(G.type_Expression); entry_lock(remain);
  Arrow_copy((Arrow *)&e->module,(Arrow *)&remain->module);
  ListingPosition_copy(&e->position,&remain->position);
  Array_resize(&remain->arguments,e->arguments.nb-1);
  for(i=0; i<remain->arguments.nb; i++)
    Array_set_index(&remain->arguments,i,Array_get_index(&e->arguments,i+1));
  Expression_compile_step4(remain,e0->result,e0->access);
  Expression_suckup_error(e,remain);
  if(Expression_is_compiled(remain) && !error_notified()) {
    Expression_suckup(e,e0);
    Expression_suckup(e,remain);
    Expression_set_result(e,remain->result,remain->access); }
  entry_unlock(remain); }
     

/*
doc
  ['{}' operator]
*/

FUNCTION Void bloc_meta(struct Expression *e) {
  Int i; struct Expression *ei;
  Expression_set_void_result(e);
  for(i=0; i<e->arguments.nb; i++) {
    ei=EARG(e,i);
    Expression_compile(ei);
    if(error_notified()) return;
    Expression_suckup(e,ei); 
    Expression_set_result(e,ei->result,ei->access); } }


/*
doc
  ['constant' function]
*/

FUNCTION Void constant_meta(struct Expression *e) {
  struct Str *name; struct Expression *value; Address result;
  if(e->arguments.nb!=2) return;
  name=(struct Str *)Expression_pure_ident(EARG(e,0)); if(name==null) return;
  value=EARG(e,1); Expression_compile(value); if(error_notified()) return;
  result=Expression_evaluate(value);
  if(result!=null) {
    Expression_define(e,name,result,Module_actual(e->module));
    Expression_set_void_result(e);
  other
    error_notifyn(error_id_compile,Z,"Failed to evaluate constant ",S,name,END); } }


/*
doc
  ['var' function (when used outside a function definition)]
*/

FUNCTION Void gvar_meta(struct Expression *e) {
  struct Type *type;
  Int i; Arrow v;
  Int i; Arrow v,w;
  struct GlobalVariable *gv;
  struct Argument *a,*a2;
  if(e->arguments.nb<2) return;
  type=(struct Type *)Expression_constant(EARG(e,0),G.type_Type); if(type==null) return;
  for(i=1; i<e->arguments.nb; i++)
    if(Expression_pure_ident(EARG(e,i))==null) return;
  for(i=1; i<e->arguments.nb; i++) {
    v=entry_new(type);
    gv=(struct GlobalVariable *)entry_new(G.type_GlobalVariable);
    w=entry_new(G.type_GlobalVariable); gv=(struct GlobalVariable *)w;
    Str_copy((struct Str *)Expression_pure_ident(EARG(e,i)),&gv->name);
    ListingPosition_copy(&e->position,&gv->position);
        ListingPosition_copy(&e->position,&gv->position);
    Arrow_set(&gv->variable,v);
    gv->access=Arw|Access_object;
    Expression_define(e,&gv->name,gv,Module_actual(e->module)); }
    Expression_define(e,&gv->name,gv,Module_actual(e->module)); 
    call_active(w,Access_read|Access_constant,EARG(e,i));
  }
  a=argument(G.type_Address,Argument_constant,entry(G.type_Address,v,END));
  List_append(&a->requires,v);
  a2=argument(type,Argument_indirect,a,0);
  Expression_set_result(e,a2,Arw|Access_object); }


/*****************************************************************************/


/*
doc
  section "if"
  ['if' function is a bit complicated because it has been written so that when the condition is a constant (imm!=null), only the requested bloc will be compiled. It means that Pliant 'if' can be used where you use '#if' in a standard C program.]
*/

FUNCTION Void if_meta(struct Expression *e) {
  struct Instruction *cond,*jmp,*next,*endif;
  Bool *imm;
  Int i; struct Expression *ei; struct Str temp;
  if(e->arguments.nb<2) return;
  if(!Expression_cast(EARG(e,0),G.type_CBool)) return;
  for(i=2; i<e->arguments.nb;) {
    ei=EARG(e,i);
    if(entry_type(ei->value)==G.type_Ident && compare_str((struct Str *)ei->value,Str_map_string(&temp,"eif"))==compare_equal) {
      if(ei->arguments.nb!=0 || i+2>=e->arguments.nb || !Expression_cast(EARG(e,i+1),G.type_CBool)) return;
      i+=3;
    orif(entry_type(ei->value)==G.type_Ident && compare_str((struct Str *)ei->value,Str_map_string(&temp,"else"))==compare_equal)
      if(ei->arguments.nb!=0 || i+2!=e->arguments.nb) return;
      i+=2;
    other
      return; } }
  if(i!=e->arguments.nb) return;
  next=instruction(G.function_do_nothing,END);
  endif=instruction(G.function_do_nothing,END);
  imm=(Bool *)Expression_constant(EARG(e,0),G.type_CBool);
  if(imm==null) {
    Expression_cast(EARG(e,0),G.type_CBool); Expression_suckup(e,EARG(e,0));
    cond=instruction(G.function_jump_if_not,EARG(e,0)->result,END);
    Instruction_set_jump(cond,next);
    Expression_add(e,cond);
    Expression_compile(EARG(e,1)); if(error_notified()) return;
    Expression_suckup(e,EARG(e,1));
    jmp=instruction(G.function_i386_jump,END);
    Instruction_set_jump(jmp,endif);
    Expression_add(e,jmp);
  orif(*imm)
    Expression_compile(EARG(e,1)); if(error_notified()) return;
    Expression_suckup(e,EARG(e,1)); }
  for(i=2; i<e->arguments.nb;) {
    ei=EARG(e,i);
    if(i+2!=e->arguments.nb) { // eif
      if(imm==null) {
        Expression_add(e,next);
        next=instruction(G.function_do_nothing,END); }
      if(imm==null || !*imm) {
        imm=(Bool *)Expression_constant(EARG(e,i+1),G.type_CBool);
        if(imm==null) {
          Expression_compile(EARG(e,i+2)); if(error_notified()) break;
          Expression_cast(EARG(e,i+1),G.type_CBool); Expression_suckup(e,EARG(e,i+1));
          cond=instruction(G.function_jump_if_not,EARG(e,i+1)->result,END); Instruction_set_jump(cond,next);
          Expression_add(e,cond);
          Expression_suckup(e,EARG(e,i+2));
          jmp=instruction(G.function_i386_jump,END); Instruction_set_jump(jmp,endif);
          Expression_add(e,jmp);
        orif(*imm)
          Expression_compile(EARG(e,i+2)); if(error_notified()) break;
          Expression_suckup(e,EARG(e,i+2)); } }
      i+=3;
    other // else
      if(imm==null || !*imm) {
        Expression_add(e,next);
        next=endif;
        Expression_compile(EARG(e,i+1)); if(error_notified()) break;
        Expression_suckup(e,EARG(e,i+1)); }
      i+=2; } }
  if(next!=endif) Expression_add(e,next);
  Expression_add(e,endif);
  Expression_set_void_result(e); }


/*
doc
  section "while"
  ['while' function]
*/

FUNCTION Void while_meta(struct Expression *e) {
  struct Instruction *back,*test,*jump,*i;
  if(e->arguments.nb!=2) return;
  if(!Expression_cast(EARG(e,0),G.type_CBool)) return;
  Expression_compile(EARG(e,1)); if(error_notified()) return;
  test=instruction(G.function_do_nothing,END);
  jump=instruction(G.function_i386_jump,END); Instruction_set_jump(jump,test);
  Expression_add(e,jump);
  back=instruction(G.function_do_nothing,END);
  Expression_add(e,back);
  Expression_suckup(e,EARG(e,1));
  Expression_add(e,test);
  Expression_suckup(e,EARG(e,0));
  i=instruction(G.function_jump_if,EARG(e,0)->result,END); Instruction_set_jump(i,back);
  Expression_add(e,i);
  Expression_set_void_result(e); }


/*
doc
  section "for"
  ['for' function]
*/

FUNCTION Void for_meta(struct Expression *e) {
  struct Expression *var,*start,*stop,*step,*body;
  struct Instruction *back,*stepispos,*stepisneg,*end;
  struct Instruction *i; struct Argument *targ,*carg,*marg,*zarg,*rarg,*sarg;
  struct Str temp; struct Str *id;
  if(e->arguments.nb!=4) {
    if(e->arguments.nb!=6) return;
    id=(struct Str *)Expression_pure_ident(EARG(e,3));
    if(id==null || compare_str(id,Str_map_string(&temp,"step"))!=compare_equal) return;
    step=EARG(e,4);
  other
    step=null; }
  var=EARG(e,0); if(!Expression_cast(var,G.type_Int) || !(var->access&Access_write)) return;
  start=EARG(e,1); if(!Expression_cast(start,G.type_Int)) return;
  stop=EARG(e,2); if(!Expression_cast(stop,G.type_Int)) return;
  if(step!=null)
    if(!Expression_cast(step,G.type_Int)) return;
  body=EARG(e,e->arguments.nb-1);
  Expression_compile(body); if(error_notified()) return;
  Expression_suckup(e,var);
  Expression_suckup(e,start);
  Expression_suckup(e,stop);
  if(step!=null)
    Expression_suckup(e,step);
  targ=argument(G.type_Type,Argument_constant,G.type_Int);
  Expression_add(e,instruction(G.function_copy_universal,start->result,var->result,targ,END));
  back=instruction(G.function_do_nothing,END);
  if(step!=null) {
    stepisneg=instruction(G.function_do_nothing,END);
    stepispos=instruction(G.function_do_nothing,END); }
  end=instruction(G.function_do_nothing,END);
  Expression_add(e,back);

  if(step!=null) {
    zarg=argument(G.type_Int,Argument_constant,entry(G.type_Int,0,END));
    carg=argument(G.type_Int,Argument_local);
    marg=argument(G.type_Int,Argument_constant,entry(G.type_Int,1,END));
    rarg=argument(G.type_CBool,Argument_local);
    Expression_add(e,instruction(G.function_compare_int,step->result,zarg,carg,END));
    Expression_add(e,instruction(G.function_compare_apply_mode,carg,marg,rarg,END));
    i=instruction(G.function_jump_if,rarg,END); Instruction_set_jump(i,stepisneg);
    Expression_add(e,i); }

  carg=argument(G.type_Int,Argument_local);
  marg=argument(G.type_Int,Argument_constant,entry(G.type_Int,4,END));
  rarg=argument(G.type_CBool,Argument_local);
  Expression_add(e,instruction(G.function_compare_int,var->result,stop->result,carg,END));
  Expression_add(e,instruction(G.function_compare_apply_mode,carg,marg,rarg,END));
  i=instruction(G.function_jump_if,rarg,END); Instruction_set_jump(i,end);
  Expression_add(e,i);

  if(step!=null) {
    i=instruction(G.function_i386_jump,END); Instruction_set_jump(i,stepispos);
    Expression_add(e,i);
    Expression_add(e,stepisneg);
    carg=argument(G.type_Int,Argument_local);
    marg=argument(G.type_Int,Argument_constant,entry(G.type_Int,1,END));
    rarg=argument(G.type_CBool,Argument_local);
    Expression_add(e,instruction(G.function_compare_int,var->result,stop->result,carg,END));
    Expression_add(e,instruction(G.function_compare_apply_mode,carg,marg,rarg,END));
    i=instruction(G.function_jump_if,rarg,END); Instruction_set_jump(i,end);
    Expression_add(e,i);
    Expression_add(e,stepispos); }

  Expression_suckup(e,body);

  if(step!=null)
    sarg=step->result;
  else
    sarg=argument(G.type_Int,Argument_constant,entry(G.type_Int,1,END));
  i=instruction(G.function_plus_Int,var->result,sarg,var->result,END);
  Expression_add(e,i);
  i=instruction(G.function_i386_jump,END); Instruction_set_jump(i,back);
  Expression_add(e,i);

  Expression_add(e,end);
  Expression_set_void_result(e); }


/*****************************************************************************/

/*
doc
  [The remaining functions should be understandable without extra comments.]
*/

FUNCTION Void cast_meta(struct Expression *e) {
  struct Expression *obj; struct Type *type;
  if(e->arguments.nb!=2) return;
  obj=EARG(e,0); Expression_compile(obj); if(error_notified()) return;
  type=Expression_constant(EARG(e,1),G.type_Type); if(type==null) return;
  if(!Expression_cast2(obj,type,0)) return;
  Expression_suckup(e,obj);
  Expression_set_result(e,obj->result,obj->access); }


FUNCTION Void addressof_meta(struct Expression *e) { /// section "addressof"
  struct Expression *expr; struct Type *t;
  struct Argument *arg; struct Instruction *instr;
  if(e->arguments.nb!=1) return;
  expr=EARG(e,0); Expression_compile(expr); if(error_notified()) return;
  t=Type_real_data_type(expr->result->type); Expression_cast(expr,t);
  Expression_suckup(e,expr);
  arg=argument(G.type_Address,Argument_local);
  instr=instruction(G.function_address_universal,expr->result,arg,END);
  Expression_add(e,instr);
  Expression_set_result(e,arg,Ar); }


FUNCTION Void typeof_meta(struct Expression *e) {
  struct Expression *expr; struct Type *t;
  struct Argument *arg; struct Instruction *instr;
  if(e->arguments.nb!=1) return;
  expr=EARG(e,0); Expression_compile(expr); if(error_notified()) return;
  t=Type_real_data_type(expr->result->type); Expression_cast(expr,t);
  Expression_set_constant_result(e,t); }


FUNCTION Void the_function_meta(struct Expression *e) {
  struct Str *name; Int i;
  Int nb_arg,nb_res;
  Arrow *c; struct Function *fi,*f; Int count;
  struct Str temp; struct Str *id;
  if(e->arguments.nb<1) return;
  if((name=(struct Str *)Expression_pure_ident(EARG(e,0)))==null)
    return;
  nb_arg=e->arguments.nb-1,nb_res=0;
  if(e->arguments.nb>=3 && (id=(struct Str *)Expression_pure_ident(EARG(e,e->arguments.nb-2)))!=null && compare_str(id,Str_map_string(&temp,"->"))==compare_equal)
    nb_arg-=2,nb_res=1;
  for(i=0; i<nb_arg; i++)
    if(Expression_constant(EARG(e,i+1),G.type_Type)==null)
      return;
  if(nb_res!=0 && Expression_constant(EARG(e,e->arguments.nb-1),G.type_Type)==null)
    return;
  count=0;
  for(c=Module_first(e->module,name); c!=G.null_constant; c=Module_next(e->module,name,c))
    if(entry_type(*c)==G.type_Function || entry_type(*c)==G.type_Meta) {
      fi=(struct Function *)*c;
      if(fi->nb_arg!=nb_arg || fi->nb_argres!=nb_arg+nb_res)
        continue;
      for(i=0; i<nb_arg; i++)
        if(fi->arguments[i].type!=Expression_constant(EARG(e,i+1),G.type_Type))
          break;
      if(i!=nb_arg) continue;
      if(nb_res!=0 && Expression_constant(EARG(e,e->arguments.nb-1),G.type_Type)!=fi->arguments[nb_arg].type)
        continue;
      f=fi,count++; }
  if(count==1) {
    Expression_set_result(e,argument(entry_type(f),Argument_indirect,
      argument(G.type_Address,Argument_constant,entry(G.type_Address,f,END))
      ,0),Arw); 
    List_append(&e->result->requires,f); } }


FUNCTION Void the_meta_meta(struct Expression *e) {
  struct Str *name;
  Arrow *c; struct Function *f; Int count;
  if(e->arguments.nb!=1) return;
  if((name=Expression_pure_ident(EARG(e,0)))==null)
    return;
  count=0;
  for(c=Module_first(e->module,name); c!=G.null_constant; c=Module_next(e->module,name,c))
    if(entry_type(*c)==G.type_Meta)
      f=(struct Function *)*c,count++;
  if(count==1) {
    Expression_set_result(e,argument(G.type_Meta,Argument_indirect,
      argument(G.type_Address,Argument_constant,entry(G.type_Address,f,END))
      ,0),Arw);
    List_append(&e->result->requires,f); } }


FUNCTION Void anymap_meta(struct Expression *e,Int mode) { ///section "map"
  struct Expression *etype,*adr; struct Type *type;
  struct Argument *a,*a2;
  if(e->arguments.nb!=2) return;
  adr=EARG(e,0);
  etype=EARG(e,1); type=Expression_constant(etype,G.type_Type); if(type==null) return;
  if(Expression_cast(adr,G.type_Address)) {
    a=adr->result;
  orif(Expression_cast(adr,G.type_Arrow))
    a=argument(G.type_Address,Argument_a_register);
    Expression_add(e,instruction(G.function_copy_atomic,adr->result,a));
  other
    return; }
  Expression_suckup(e,adr);
  Expression_suckup(e,etype);
  a2=argument(type,Argument_indirect,a,0);
  Expression_set_result(e,a2,Arw|mode); }

FUNCTION Void map_meta(struct Expression *e) {
  anymap_meta(e,0); }

FUNCTION Void omap_meta(struct Expression *e) {
  anymap_meta(e,Access_object); }


FUNCTION Void translate_meta(struct Expression *e) { /// section "translate"
  struct Expression *adr,*etype,*nb; struct Type *type;
  struct Argument *s,*m,*a;
  if(e->arguments.nb!=3) return;
  adr=EARG(e,0); if(!Expression_cast(adr,G.type_Address)) return;
  etype=EARG(e,1); type=Expression_constant(etype,G.type_Type); if(type==null) return;
  nb=EARG(e,2); if(!Expression_cast(nb,G.type_Int)) return;
  Expression_suckup(e,adr);
  Expression_suckup(e,etype);
  Expression_suckup(e,nb);
  s=argument(G.type_Int,Argument_constant,entry(G.type_Int,type->size,END));
  m=argument(G.type_Int,Argument_local);
  Expression_add(e,instruction(G.function_multiply_Int,nb->result,s,m,END));
  a=argument(G.type_Address,Argument_local);
  Expression_add(e,instruction(G.function_plus_Int,adr->result,m,a,END));
  Expression_set_result(e,a,Arw); }


FUNCTION Void new_meta(struct Expression *e) { /// section "new"
  struct Expression *etype; struct Type *type;
  struct Argument *a;
  if(e->arguments.nb!=1) return;
  etype=EARG(e,0); type=Expression_constant(etype,G.type_Type); if(type==null) return;
  Expression_suckup(e,etype);
  a=argument(type,Argument_indirect,argument(G.type_Address,Argument_local),0);
  Expression_add(e,instruction(G.function_entry_new,etype->result,a->u.indirect.pointer,END));
  Expression_set_result(e,a,Arw|Access_object); }