Patch title: Release 85 bulk changes
Abstract:
File: /pliant/language/basic/basic.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
  [Some Pliant very basic functions: not and or + := :> = <> < > <= >=]
doc
  [All theses are implemented as 'meta' functions because they cannot be implemented as standard functions: in classical languages, either they are built in, or you cannot define them at all.]
*/


static Bool not_CBool(Bool c) {
  return !c; }

static Void and_meta(struct Expression *e) {
  struct Instruction *test,*endand; struct Argument *res;
  if(e->arguments.nb!=2) return;
/*
doc
  ['and' is optimized so that:]
  list
    item [false and x is false]
    item [true and x is x]
    item [x and false is false]
    item [true and x is x]
*/
  if(Expression_constant(EARG(e,0),G.type_CBool)!=null) 
    if(!*(Bool *)Expression_constant(EARG(e,0),G.type_CBool)) {
      Expression_set_constant_result(e,G.false_constant);
      return;
    orif(Expression_cast(EARG(e,1),G.type_CBool)) 
      Expression_suckup(e,EARG(e,1));
      Expression_set_result(e,EARG(e,1)->result,EARG(e,1)->access); 
      return; } 
  if(Expression_constant(EARG(e,1),G.type_CBool)!=null) 
    if(!*(Bool *)Expression_constant(EARG(e,1),G.type_CBool)) {
      Expression_set_constant_result(e,G.false_constant);
      return;
    orif(Expression_cast(EARG(e,0),G.type_CBool)) 
      Expression_suckup(e,EARG(e,0));
      Expression_set_result(e,EARG(e,0)->result,EARG(e,0)->access); 
      return; }
/*
doc
  [Now the general case where none of the arguments is a constant:]  
*/
  if(!Expression_cast(EARG(e,0),G.type_CBool) || !Expression_cast(EARG(e,1),G.type_CBool)) return;
  endand=instruction(G.function_do_nothing,END);
  res=argument(G.type_CBool,Argument_local);
  Expression_add(e,instruction(G.function_copy_atomic,argument(G.type_CBool,Argument_constant,G.false_constant),res,END));
  Expression_suckup(e,EARG(e,0));
  test=instruction(G.function_jump_if_not,EARG(e,0)->result,END); Instruction_set_jump(test,endand);
  Expression_add(e,test);
  Expression_suckup(e,EARG(e,1));
  test=instruction(G.function_jump_if_not,EARG(e,1)->result,END); Instruction_set_jump(test,endand);
  Expression_add(e,test);
  Expression_add(e,instruction(G.function_copy_atomic,argument(G.type_CBool,Argument_constant,G.true_constant),res,END));
  Expression_add(e,endand);
  Expression_set_result(e,res,Ar); }


static Void or_meta(struct Expression *e) {
  struct Instruction *test,*endor; struct Argument *res;
  if(e->arguments.nb!=2) return;
  if(Expression_constant(EARG(e,0),G.type_CBool)!=null) 
    if(*(Bool *)Expression_constant(EARG(e,0),G.type_CBool)) {
      Expression_set_constant_result(e,G.true_constant);
      return; 
    orif(Expression_cast(EARG(e,1),G.type_CBool)) 
      Expression_suckup(e,EARG(e,1));
      Expression_set_result(e,EARG(e,1)->result,EARG(e,1)->access); 
      return; } 
  if(Expression_constant(EARG(e,1),G.type_CBool)!=null) 
    if(*(Bool *)Expression_constant(EARG(e,1),G.type_CBool)) {
      Expression_set_constant_result(e,G.true_constant);
      return; 
    orif(Expression_cast(EARG(e,0),G.type_CBool)) 
      Expression_suckup(e,EARG(e,0));
      Expression_set_result(e,EARG(e,0)->result,EARG(e,0)->access); 
      return; } 
  if(!Expression_cast(EARG(e,0),G.type_CBool) || !Expression_cast(EARG(e,1),G.type_CBool)) return;
  endor=instruction(G.function_do_nothing,END);
  res=argument(G.type_CBool,Argument_local);
  Expression_add(e,instruction(G.function_copy_atomic,argument(G.type_CBool,Argument_constant,G.true_constant),res,END));
  Expression_suckup(e,EARG(e,0));
  test=instruction(G.function_jump_if,EARG(e,0)->result,END); Instruction_set_jump(test,endor);
  Expression_add(e,test);
  Expression_suckup(e,EARG(e,1));
  test=instruction(G.function_jump_if,EARG(e,1)->result,END); Instruction_set_jump(test,endor);
  Expression_add(e,test);
  Expression_add(e,instruction(G.function_copy_atomic,argument(G.type_CBool,Argument_constant,G.false_constant),res,END));
  Expression_add(e,endor);
  Expression_set_result(e,res,Ar); } 


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


static Void plus_Str(struct Str *a,struct Str *b,struct Str *r) {
  Int l; Char *c;
  check(Str_len(a)>=0 && Str_len(b)>=0);
  l=Str_len(a)+Str_len(b);
  c=(Char *)memory_allocate(l,r);
  memory_copy(a->chars,c,Str_len(a));
  memory_copy(b->chars,c+Str_len(a),Str_len(b));
  if(r->len2&Str_allocated) memory_free(r->chars);
  r->chars=c;
  r->len2=l|Str_allocated; }


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

/*
doc
  ['copy Universal' is a very usefull Pliant function that enables you to copy any Pliant data, provided you know it's type at run time (you need not know it at compile time).] ; eol
*/

static Void generate_copy_atomic(struct Instruction *instr,struct GeneratorContext *gc) {
  struct Instruction *current;
  struct Argument *arg;
  current=instr;
  arg=argument(G.type_Int,Argument_a_register);
  current=GeneratorContext_insert_after_instruction(gc,current,instruction(G.function_i386_mov,IARG(instr,0),arg,END));
  current=GeneratorContext_insert_after_instruction(gc,current,instruction(G.function_i386_mov,arg,IARG(instr,1),END));
  GeneratorContext_remove(gc,instr); }

static Void copy_universal(Address src,Address dest,struct Type *type) {
  Type_copy_instance(type,src,dest); }


/*
doc
  section "set"
  [':=' operator]
*/

static Void set_meta(struct Expression *e) {
  struct Expression *var,*value; struct Type *type;
  struct Argument *targ; struct Instruction *instr;
  if(e->arguments.nb!=2) return;
  var=EARG(e,0),value=EARG(e,1);
  Expression_compile(var); if(error_notified() || !(var->access&Access_write)) return;
  Expression_compile(value); if(error_notified()) return;
/*
doc
  [The next line is important and means that ':=' never applies on pointers, but always on true datas.]
  listing
    var Int i := 2
    var Pointer:Int j :> i
    var Int k := 3
    var Pointer:Int l :> k
    j := l
    console i eol
  [would display 3.]
*/
  type=Type_real_data_type(var->result->type);
  if(!Expression_cast(var,type) || !(var->access&Access_write) || !Expression_cast2(value,type,Function_flag_implicit|Function_flag_extension|Function_flag_reduction)) return;
  #ifdef _EXPERIMENTAL_
    Expression_suckup(e,var);
    Expression_suckup(e,value);
  #else
    Expression_suckup(e,value);
    Expression_suckup(e,var);
  #endif
  targ=argument(G.type_Type,Argument_constant,type);
  instr=instruction(G.function_copy_universal,value->result,var->result,targ,END);
  Expression_add(e,instr);
  Expression_set_void_result(e); }


/*
doc
  ['address Universal' is a function mainly used by meta programming functions.] ; eol
  [It will simply return a pointer to the provided data.]
*/

static Address address_universal(Address a) {
  return a; }

#ifdef _i386_
  static Void generate_address_universal(struct Instruction *instr,struct GeneratorContext *gc) {
    struct Argument *src,*dest;
    struct Argument *a; struct Instruction *current;
    src=IARG(instr,0),dest=IARG(instr,1);
    switch(src->where) {
      case Argument_constant:
        a=argument(G.type_Address,Argument_constant,entry(G.type_Address,src->u.constant,END));
        List_append(&a->requires,src->u.constant);
        GeneratorContext_insert_after_instruction(gc,instr,instruction(G.function_i386_mov,a,dest,END));
        break;
      case Argument_indirect:
      case Argument_local:
        if(dest->where==Argument_register || dest->where==Argument_a_register) {
          GeneratorContext_insert_after_instruction(gc,instr,instruction(G.function_i386_lea,src,dest,END));
        other
          a=argument(G.type_Address,Argument_a_register);
          current=instr;
          current=GeneratorContext_insert_after_instruction(gc,current,instruction(G.function_i386_lea,src,a,END));
          GeneratorContext_insert_after_instruction(gc,current,instruction(G.function_i386_mov,a,dest,END)); }
        break;
      default:
        error_notifyn(error_id_unexpected,Z,"Invalid argument location",END);
        return; }
    GeneratorContext_remove(gc,instr); }
#endif


/*
doc
  ['arrow Universal' is very similar to 'address Universal' but will set an arrow to the data, so the data must be a true object.]
*/

static Void arrow_universal(Address a,Arrow *r) {
  Arrow_set(r,a); }


/*
doc
  ['translate Univeral' is extracting the address of the object, just like 'address Universal' then translate it.]
  [It's mainly used to set the pointer field of an indirect argument that will map a field in the data.]
*/

static Address address_and_translate_universal(Address a,Int i) {
  return address_translate(a,i); }

#ifdef _i386_
  static Void generate_address_and_translate_universal(struct Instruction *instr,struct GeneratorContext *gc) {
    struct Argument *src,*dest,*off; Int offset;
    struct Argument *a; struct Instruction *current;
    src=IARG(instr,0),off=IARG(instr,1),dest=IARG(instr,2);
    check(off->type==G.type_Int && off->where==Argument_constant);
    offset=*(Int *)off->u.constant;
    switch(src->where) {
      case Argument_constant:
        a=argument(G.type_Address,Argument_constant,entry(G.type_Address,address_translate(src->u.constant,offset),END));
        List_append(&a->requires,src->u.constant);
        GeneratorContext_insert_after_instruction(gc,instr,instruction(G.function_i386_mov,a,dest,END));
        break;
      case Argument_indirect:
      case Argument_local:
        current=instr;
        if(src->where==Argument_indirect && src->u.indirect.pointer->where==Argument_constant) {
          a=argument(G.type_Address,Argument_constant,entry(G.type_Address,address_translate(*(Address *)src->u.indirect.pointer->u.constant,src->u.indirect.offset+offset),END));
          List_copy(&src->requires,&a->requires);
          GeneratorContext_insert_after_instruction(gc,instr,instruction(G.function_i386_mov,a,dest,END));
          break;
        orif(dest->where==Argument_register || dest->where==Argument_a_register)
          if(src->where==Argument_indirect && src->u.indirect.offset==0) {
            a=argument(src->type,Argument_indirect,src->u.indirect.pointer,offset);
            GeneratorContext_insert_after_instruction(gc,current,instruction(G.function_i386_lea,a,dest,END));
          other
            current=GeneratorContext_insert_after_instruction(gc,current,instruction(G.function_i386_lea,src,dest,END));
            GeneratorContext_insert_after_instruction(gc,current,instruction(G.function_i386_add,off,dest,END)); }
        other
          a=argument(G.type_Address,Argument_a_register);
          current=GeneratorContext_insert_after_instruction(gc,current,instruction(G.function_i386_lea,src,a,END));
          current=GeneratorContext_insert_after_instruction(gc,current,instruction(G.function_i386_mov,a,dest,END));
          GeneratorContext_insert_after_instruction(gc,current,instruction(G.function_i386_add,off,dest,END)); }
        break;
      default:
        error_notifyn(error_id_unexpected,Z,"Invalid argument location",END);
        return; }
    GeneratorContext_remove(gc,instr); }
#endif


/*
doc
  section "point"
  [':>' operator]
*/

static Void point_meta(struct Expression *e) {
  struct Expression *var,*value; struct Type *ptr,*type,*type2;
  struct Instruction *instr;
  if(e->arguments.nb!=2) return;
  var=EARG(e,0),value=EARG(e,1);
  Expression_compile(var); if(error_notified() || !(var->access&Access_write)) return;
  for(ptr=null,type=var->result->type; (type2=unpointerto(type))!=null; ptr=type,type=type2);
  if(ptr==null || !Expression_cast(var,ptr) || !Expression_cast(value,type)) return;
  if(type_is_pointer(ptr)) {
    instr=instruction(G.function_address_universal,value->result,var->result,END);
  orif(type_is_link(ptr))
    instr=instruction(G.function_arrow_universal,value->result,var->result,END);
  other
    return; }
  Expression_suckup(e,value);
  Expression_suckup(e,var);
  Expression_add(e,instr);
  Expression_set_void_result(e); }


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


static Bool compare_apply_mode(Int compare,Int mode) {
  check(compare==compare_inferior ||
        compare==compare_equal ||
        compare==compare_superior ||
        compare==compare_different ||
        compare==compare_unknown);
  check( (compare&(compare_inferior+compare_equal+compare_superior)) ||
         (mode&compare_inferior ? 1 : 0)==(mode&compare_superior ? 1 : 0) );
  return compare&mode; }

/*
doc
  ['=' , '<>' , '<' , '>' , '<=' and '>=' operators]
*/

static Void compare_meta(struct Expression *e,Int mode) {
  struct Expression *e2; struct Argument *marg,*rarg;
  if(e->arguments.nb!=2) return;
  e2=(struct Expression *)entry_new(G.type_Expression); entry_lock(e2);
  Expression_copy(e,e2); Expression_uncompile(e2);
  Arrow_set(&e2->value,entry(G.type_Ident,"compare",END));
  if(!Expression_cast(e2,G.type_Int)) {
    entry_unlock(e2);
    return; }
  Expression_suckup(e,e2);
  marg=argument(G.type_Int,Argument_constant,entry(G.type_Int,mode,END));
  rarg=argument(G.type_CBool,Argument_local);
  Expression_add(e,instruction(G.function_compare_apply_mode,e2->result,marg,rarg,END));
  Expression_set_result(e,rarg,Access_read);
  entry_unlock(e2); }  

static Void equal_meta(struct Expression *e) {
  compare_meta(e,compare_equal); }

static Void different_meta(struct Expression *e) {
  compare_meta(e,compare_inferior+compare_superior+compare_different); }

static Void inferior_meta(struct Expression *e) {
  compare_meta(e,compare_inferior); }

static Void superior_meta(struct Expression *e) {
  compare_meta(e,compare_superior); }

static Void inferior_or_equal_meta(struct Expression *e) {
  compare_meta(e,compare_inferior+compare_equal); }

static Void superior_or_equal_meta(struct Expression *e) {
  compare_meta(e,compare_superior+compare_equal); }