Lhogho  0.0.027
Data Structures | Defines | Typedefs | Functions | Variables
vars.c File Reference

Data Structures

struct  prim_t
 description of a primitive More...

Defines

#define FLAG_EX_PRINTDEPTHLIMIT   0x00010000
 extended flag for PRINTDEPTHLIMIT
#define FLAG_EX_PRINTWIDTHLIMIT   0x00020000
 extended flag for PRINTWIDTHLIMIT
#define FLAG_EX_FULLPRINTP   0x00040000
 extended flag for FULLPRINTP
#define FLAG_EX_CASEIGNOREDP   0x00080000
 extended flag for CASEIGNOREDP
#define FLAG_EX_LOGOPLATFORM   0x00100000
 extended flag for LOGOPLATFORM
#define FLAG_EX_LOGOVERSION   0x00200000
 extended flag for LOGOVERSION
#define FLAG_EX_LOGODIALECT   0x00400000
 extended flag for LOGODIALECT
#define DUMP_BUF_SIZE   128

Typedefs

typedef struct prim_t primitive_t
 description structure of a primitive

Functions

void init_vars ()
 initializes variables
void finit_vars ()
 finalizes the Varss module
atom_t new_var (atom_t name, atom_t parent, int attach)
 creates a new var atom
int need_descr2 (atom_t var)
 creates var descriptor if needed
void delete_var (atom_t a)
 deletes var atom
void dump_var (atom_t a, int level)
 dumps error atom
atom_t find_var (atom_t name, atom_t parent)
 searches a variable
atom_t find_local_runtime_var (atom_t name, int frame)
 searches a variable at runtime
atom_t find_runtime_var (atom_t name, int frame)
 searches a variable at runtime
atom_t find_local_var (atom_t name, atom_t parent)
 searches a local variable
atom_t new_local_var (atom_t name, atom_t function, int quoted)
 creates a new local var
void copy_local_vars (int frame)
 copy local vars to parent

Variables

atom_t root
 parent of all variables
atom_t word_to
 word containing "TO" token
atom_t word_to_syn
 word containing a synonym of "TO" token
atom_t word_end
 word containing "END" token
atom_t word_run
 word containing "RUN" token
atom_t word_make
 word containing "MAKE" token
atom_t word_plus
 word containing "+" token
atom_t word_toplevel
 word containing "TOPLEVEL" token
atom_t word_system
 word containing "SYSTEM" token
atom_t word_error
 word containing "ERROR" token
atom_t unbound
 atom representing unbound values
atom_t stopped
 atom representing stop values
atom_t repeat_chain
 atom for the topmost repeat chain
atom_t globals
 collection of global system-wide persistent variables
atom_t printdepthlimit
 variable PRINTDEPTHLIMIT
atom_t printwidthlimit
 variable PRINTWIDTHLIMIT
atom_t fullprintp
 variable FULLPRINTP
atom_t caseignoredp
 variable CASEIGNOREDP
atom_t last_error
 last caught error (used by ERROR primitive)
atom_t delayed_free
 atoms sheduled for delayed free
int root_frame
 frame of root
int backup_frame
 run-time backup of frame
atom_t error_flag
 error flag (used by internal/external functions)
int catch_output_flag
 1 = there was output/stop in catch
primitive_t vars []
 array with actual properties of primitives

Define Documentation

#define FLAG_EX_PRINTDEPTHLIMIT   0x00010000
#define FLAG_EX_PRINTWIDTHLIMIT   0x00020000
#define FLAG_EX_FULLPRINTP   0x00040000
#define FLAG_EX_CASEIGNOREDP   0x00080000
#define FLAG_EX_LOGOPLATFORM   0x00100000
#define FLAG_EX_LOGOVERSION   0x00200000
#define FLAG_EX_LOGODIALECT   0x00400000
#define DUMP_BUF_SIZE   128

Typedef Documentation

typedef struct prim_t primitive_t

Function Documentation

as local variables to the root variable. The names of primitives are taken from TR_PRIMITIVES, the properties are taken from vars[]. Two words :to and :end are created.

Initializes the variables module by creating the system root variable which is named as defined by ROOT_VAR_NAME, and globals variable defined by

{
  #ifdef DEBUG_VAR
  printf("<VAR> Vars initialized\n");
  #endif //DEBUG_VAR

  // create the root variable
  atom_t name = new_word( ROOT_VAR_NAME, -1 );
  root = new_var( name, 0, 0 );
  need_descr2( root );
  SET_FLAGS( root, FLAG_FUNCTION );
  LARGS( root ) = 0;
  RARGS( root ) = 0;
  LEVEL( root ) = 0;
  PRIORITY( root ) = PRIORITY_CMD;
  DEUSE( name );

  // create the globals variable
  name = new_word( GLOBALS_VAR_NAME, -1 );
  globals = new_var( name, 0, 0 );
  SET_FLAGS( globals, FLAG_VARIABLE );
  LARGS( root ) = 0;
  RARGS( root ) = 0;
  LEVEL( root ) = 0;
  PRIORITY( root ) = PRIORITY_CMD;
  DEUSE( name );

  unbound = new_integer( 0 );
  stopped = new_integer( 1 );

  repeat_chain = new_list( new_integer(0), empty_list );
  REPCOUNT( CAR(repeat_chain) ) = -1;

  last_error = empty_list;
  delayed_free = empty_list;

  atom_t names = new_word( TR_PRIMITIVES, UNKNOWN );
  atom_t tokens = tokenize( names, TOKENIZE_DATA );

  // setting TO, END and other words
  atom_t t = tokens; 
  false_true[0] = USE(CAR(t)); t = CDR(t);
  false_true[1] = USE(CAR(t)); t = CDR(t);
  word_to       = USE(CAR(t)); t = CDR(t);
  word_to_syn   = USE(CAR(t)); t = CDR(t);
  word_end      = USE(CAR(t)); t = CDR(t);
  word_toplevel = USE(CAR(t)); t = CDR(t);
  word_system   = USE(CAR(t)); t = CDR(t);
  word_error    = USE(CAR(t)); t = CDR(t);
  //word_run -- set in the next FOR-cycle

  // create primitives
  int i;
  for( i = 0; vars[i].largs>=0; i++, t=CDR(t) )
    {
      #ifdef SAFEMODE
        assert( IS_NOT_EMPTY(t) ); // too few words in TR_PRIMITIVES
      #endif

      //printf("%d ",i); dumpln(CAR(t));
      atom_t name = CAR(t);
      if( LENGTH(name) )
      {
        atom_t var = new_var( name, globals, 1 );
        ADDRESS( var ) = (int_t)vars[i].function;
        LEVEL( var ) = 1;
        LARGS( var ) = vars[i].largs;
        RARGS( var ) = vars[i].rargs;

        if( vars[i].flags & FLAG_PRIORITY_MUL )
          PRIORITY( var ) = PRIORITY_MUL;
        else if( vars[i].flags & FLAG_PRIORITY_ADD )
          PRIORITY( var ) = PRIORITY_ADD;
        else if( vars[i].flags & FLAG_PRIORITY_LOG )
          PRIORITY( var ) = PRIORITY_LOG;
        else if( vars[i].flags & FLAG_PRIORITY_CMP )
          PRIORITY( var ) = PRIORITY_CMP;
        else if( vars[i].flags & FLAG_COMMAND )
          PRIORITY( var ) = PRIORITY_CMD;
        else
          PRIORITY( var ) = PRIORITY_FUN;

        SET_FLAGS( var, (vars[i].flags&ALL_VAR_FLAGS) | FLAG_PRIMITIVE );

        // initialize system variables to (unbound)
        if( IS_VARIABLE(var) )
          {
            if( vars[i].flags & FLAG_EX_PRINTDEPTHLIMIT ) printdepthlimit = var;
            if( vars[i].flags & FLAG_EX_PRINTWIDTHLIMIT ) printwidthlimit = var;
            if( vars[i].flags & FLAG_EX_FULLPRINTP      ) fullprintp = var;
            if( vars[i].flags & FLAG_EX_CASEIGNOREDP    ) caseignoredp = var;

            if( vars[i].flags & FLAG_EX_LOGOPLATFORM )
              VALUE(var) = new_word(LOGO_PLATFORM,-1);
            else if( vars[i].flags & FLAG_EX_LOGOVERSION )
              VALUE(var) = new_word(LOGO_VERSION,-1);
            else if( vars[i].flags & FLAG_EX_LOGODIALECT )
              VALUE(var) = new_word(LOGO_DIALECT,-1);
            else
              VALUE(var) = USE( unbound );

            VARTYPE(var) = VAR_TYPE_RUNTIME; // value is in var's atom
          }
        
        //printf("{%d",REF(word_run));      
        if( ADDRESS(var) == (int_t)rt_run  ) word_run  = USE(name);
        if( ADDRESS(var) == (int_t)rt_make ) word_make = USE(name);
        if( ADDRESS(var) == (int_t)rt_plus ) word_plus = USE(name);
        //printf("%d}\n",REF(word_run));      
      }
    }

  #ifdef SAFEMODE
    assert( IS_EMPTY(t) ); // too many words in TR_PRIMITIVES
  #endif

  DEUSE( names );
  DEUSE( tokens );
}

Finilizes the Vars module by freeing :to, :end and :root atoms. Deleting :root will recursively delete all other variables including the primitives.

Some system primitive variables like fullprintp, printwidthlimit, and printdepthlimit does not need individual finalization, because they are included in globals and finalized when globals is finalized.

{
  DEUSE( globals );
  DEUSE( root );
  DEUSE( repeat_chain );

  if( REF(last_error)>1 ) REF(last_error)=1; // patch

#ifdef SAFEMODE
  //printf( "REF(unbound)=%d\n",REF(unbound) );
  //printf( "REF(false_true[0])=%d\n",REF(false_true[0]) );
  //printf( "REF(last_error=%x)=%d\n",(int)last_error,REF(last_error) );
  //printf( "REF(word_run=%x)=%d\n",(int)word_run,REF(word_run) );
  assert( REF(unbound)==1 );
  assert( REF(stopped)==1 );
  assert( REF(word_error)==1 );
  assert( REF(word_system)==1 );
  assert( REF(word_toplevel)==1 );
  assert( REF(word_to)==1 );
  assert( REF(word_to_syn)==1 );
  assert( REF(word_end)==1 );
  assert( REF(false_true[0])==1 );
  assert( REF(false_true[1])==1 );
  assert( REF(word_run)==1 );
  assert( REF(word_make)==1 );
  assert( REF(word_plus)==1 );
  assert( REF(last_error)==1 );
#endif

  // IMPORTANT! The unbound atom is considered
  // not use-able amd deuse-able, thus its reference
  // count is always 1. Because of this DEUSE will
  // not automatically delete it, thus we delete is
  // manually and adjust statistics manually.
  DEUSE( unbound );
  DEUSE( stopped );

  #ifdef ADVANCED
  stats[ID(unbound)].deallocs++;
  stats_free++;
  stats[ID(stopped)].deallocs++;
  stats_free++;
  #endif //ADVANCED
  delete_numeric( unbound ); // special case
  delete_numeric( stopped ); // special case

  DEUSE( word_error );
  DEUSE( word_system );
  DEUSE( word_toplevel );
  DEUSE( word_to );
  DEUSE( word_to_syn );
  DEUSE( word_end );
  DEUSE( false_true[0] );
  DEUSE( false_true[1] );
  DEUSE( last_error );
  DEUSE( delayed_free );
  DEUSE( word_run );
  DEUSE( word_make );
  DEUSE( word_plus );

  #ifdef DEBUG_VAR
    printf("<VAR> Vars finalized\n");
  #endif //DEBUG_VAR
}
atom_t new_var ( atom_t  name,
atom_t  parent,
int  attach 
)
Parameters:
nameword atom for the name of the variable
parentvar atom for the parent of the variable
attach1=attach to parent, 0=do not attach
Returns:
var atom

Creates a var atom describing a variable with given name and parent. The reference count of the var is set to 1, the reference count of name is increased, the reference count of parent is not changed. The function automatically creates the first descriptor of the var atom. The second descriptor is left uninitialized - it could be later created by need_descr2() if needed.

The newly created var atom is included in the list of local variables of the parent only if attach != 0. Otherwise var has a parent, but the parent does not know about the child var.

{
  #ifdef SAFEMODE
    assert( name );
    assert( IS_WORD(name)||IS_SUBWORD(name)||IS_EMPTY(name) );
    assert( !parent||IS_VARATOM(parent) );
  #endif

  atom_t a = take_from_pool( &data_pool );
  DESCR1(a) = take_from_pool( &data_pool );
  DESCR2(a) = 0;

  REF(a) = 1;
  ID(a)  = VAR_ID;

  NAME(a) = USE(name);
  FLAGS(a) = 0;
  PARENT(a) = parent; // weak link, no ref++
  VARTYPE(a) = VAR_TYPE_NORMAL;
  if( parent )
    {
      need_descr2( parent );
      if( attach ) LOCALS(parent) = new_list( a, LOCALS(parent) );
      LEVEL(a) = LEVEL(parent)+1;
      OFFSET(a) = 0;
    }
  else
    LEVEL(a) = 0;

  #ifdef DEBUG_ATOM
    printf("<ATOM>  [%08x] var="STR"\n",(int)a,STRING(name));
  #endif //DEBUG_ATOM

    #ifdef ADVANCED
    stats[ID(a)].allocs+=2;  // it's 2 because of 
    stats_free-=2;    // the 1st descriptor
    if( stats[ID(a)].max<(stats[ID(a)].allocs-stats[ID(a)].deallocs) )
      stats[ID(a)].max=(stats[ID(a)].allocs-stats[ID(a)].deallocs);
  #endif //ADVANCED


  #ifdef DEBUG_RUNTIME_ATOMS
  if( running_compiled_code )
    {
      outter( TEXT("<RUNTIME> new  "), -1 );
      dump_atom_address( a );
      dump_atom( a, 1 );
      outter( TEXT("\n"), -1 );
    }
  #endif
  #ifdef DEBUG_COMPILETIME_ATOMS
  if( compiling_code )
    {
      outter( TEXT("<COMPILETIME> new  "), -1 );
      dump_atom_address( a );
      dump_atom( a, 1 );
      outter( TEXT("\n"), -1 );
    }
  #endif

  return a;
}
int need_descr2 ( atom_t  var)
Parameters:
varvar which descriptor will be created
Returns:
1 if descriptor was created

Creates the second descriptor of a var atom if it does not exist. All the values of the new second descriptor are set to empty lists.

{
  // create descr2 if it does not exist
  if( DESCR2(var) ) return 0;
  DESCR2(var) = take_from_pool( &data_pool );

  // initialize descr2
  atom_t def = empty_list;
  def = new_list( empty_list, def ); // TREE
  def = new_list( empty_list, def ); // BODY
  def = new_list( empty_list, def ); // SOURCE
  def = new_list( empty_list, def ); // FULLSOURCE
  DEFINITIONS(var) = def;
  LOCALS(var) = empty_list;
  BINARY(var) = empty_list;

  #ifdef ADVANCED
    stats[ID(var)].allocs++;
    if( stats[ID(var)].max<(stats[ID(var)].allocs-stats[ID(var)].deallocs) )
      stats[ID(var)].max=(stats[ID(var)].allocs-stats[ID(var)].deallocs);
    stats_free--;
  #endif //ADVANCED

  return 1;
}
Parameters:
aatom to delete

Deletes var atom by returning it back to the data pool. All structures pointed to by the var atom are dereferences (and most-likely) deleted.

{
  //printf(">>>DELETEVAR "); dumpln(NAME(a));
  //if( DESCR2(a) ) { printf(">>>      DEFINITIONS "); dump_atom(DEFINITIONS(a),1); printf("\n\n"); }

  // dereference value of primitive/global variables
  if( (IS_PRIMITIVE(a) || IS_GLOBAL(a) || IS_TAG(a) || IS_RUNTIME(a)) && IS_VARIABLE(a) )
    {
      //printf(">>>DELETEVARVALUE "); dumpln(VALUE(a));
      DEUSE( VALUE(a) );
    }

  //if(a==root){printf(">>>DELETEVARNAME "); dumpln(NAME(a));}
  DEUSE( NAME(a) );

  // descriptors have no reference counts
  return_to_pool( &data_pool, DESCR1(a) );
  #ifdef ADVANCED
    stats[ID(a)].deallocs++;
    stats_free++;
  #endif //ADVANCED

  if( DESCR2(a) )
    {
      //printf(">>>DELETEVARLOCALS\n");
      //printf(">>>id=%d ref=%d\n",ID(a),REF(a));
      //dumpln(LOCALS(a));
      DEUSE( LOCALS(a) );
      //no-DEUSE( BODY(a) );
      //no-DEUSE( TREE(a) );
      //printf(">>>DELETEVARBINARY\n");
      DEUSE( BINARY(a) );
      //no-DEUSE( SOURCE(a) );
      //if( a==root )
      //{
      //printf(">>>DELETEVARDEFINITIONS\n");
      //printf(">>>BODY OF ROOT ID=%d\n",ID(root));
      //dumpln(BODY(root)); printf("========\n");
      //printf(">>>ROOT FULLSOURCE="); dumpln(FULLSOURCE(a));
      //printf(">>>ROOT SOURCE="); dumpln(SOURCE(a));
      //printf(">>>ROOT BODY="); dumpln(BODY(a));
      //printf(">>>ROOT TREE="); dumpln(TREE(a));
      //}
      //printf("vvvvvvvvvvvvvvvvvvvvvvvv\n");
      DEUSE( DEFINITIONS(a) );
      //printf("^^^^^^^^^^^^^^^^^^^^^^^^\n");
      //if( a==root )
      //{
      //printf(">>>DONE\n");
      //}
      //printf(">>>DELETEVARDEFINITIONS2\n");
      return_to_pool( &data_pool, DESCR2(a) );

      #ifdef ADVANCED
        stats[ID(a)].deallocs++;
        stats_free++;
      #endif //ADVANCED
    }
  return_to_pool( &data_pool, a );
  //if(a==root) printf(">>>          DONE!\n");
}
void dump_var ( atom_t  a,
int  level 
)
Parameters:
aatom to dump
leveldump level

Dumps var atom through the current outter function.

{
#ifdef ADVANCED
  #define DUMP_BUF_SIZE 128
  char_t buf[DUMP_BUF_SIZE];
  int n;
  int i;

  if( OPTION_USER_VARIABLES && IS_PRIMITIVE(a) ) return;

  // print required number of spaces
  for( i=0; i<level; i++ ) outter( TEXT("   "), 3 );

  // print type, name and additional info
  if( IS_PRIMITIVE(a) ) outter( TEXT("PRIM"), -1 );
  if( IS_VARIABLE(a) )  outter( TEXT("VAR"), -1 );
  if( IS_FUNCTION(a) )  outter( TEXT("FUN"), -1 );
  if( IS_COMMAND(a) )   outter( TEXT("CMD"), -1 );

  if( IS_FUNCTION(a)||IS_COMMAND(a) )
    {
      n = SPRINTF( buf, DUMP_BUF_SIZE, TEXT("[%d"), LARGS(a) );
      outter( buf, n );
      n = SPRINTF( buf, DUMP_BUF_SIZE, TEXT(":%d]"), RARGS(a) );
      outter( buf, n );
    }

  outter( TEXT(" "), 1 );
  outter( STRING(NAME(a)), LENGTH(NAME(a)) );
  //if( !IS_PRIMITIVE(a) && (IS_FUNCTION(a)||IS_COMMAND(a)) )
  //{
  //  outter( TEXT("="), 1 );
  //  dump( TREE(a) );
  //}

  if( IS_VARIABLE(a) && a!=root && a!=globals )
    if( IS_RUNTIME(a) )
      {
        outter( TEXT(" = "), 3 );
        dump_atom( VALUE(a), 1 );
      }

  outter( TEXT("\n"), 1 );

  if( DESCR2(a) )
    {
      atom_t locals = LOCALS(a);
      for( ; IS_NOT_EMPTY(locals); locals=CDR(locals) )
        dump_atom( CAR(locals), level+1 );
    }

  #undef DUMP_BUF_SIZE

#endif //ADVANCED
}
atom_t find_var ( atom_t  name,
atom_t  parent 
)
Parameters:
nameword atom containing the searched name
parentvar atom where to start the search
Returns:
found var atom or NULL if not found
Note:
search is syntax-scope based

Searches a variable named name starting from variable parent. If not found found the search continues with the parent of parent, then with its grandparent, and so on untill the root is reached. If still not found search continues within the globals variable.

This search schema can find only variables known at the time of compilation. Also, the search is strictly syntax-scope based.

{
#ifdef SAFEMODE
  assert( IS_WORD(name) || IS_SUBWORD(name) );
  assert( parent );
  assert( IS_VARATOM(parent) );
#endif

  #ifdef DEBUG_FIND_VAR
    printf("<FINDVAR> Search "); dumpln(name);
    printf("<FINDVAR> Current var tree "); dumpln(root);
  #endif

  // scan parent and its parents
  atom_t a;
  for( ; parent; parent=PARENT(parent) )
    {
      #ifdef DEBUG_FIND_VAR
        printf("<FINDVAR> Search it in parent "); dumpln(NAME(parent));
      #endif
      a = find_local_var( name, parent );
      #ifdef DEBUG_FIND_VAR
        if( a ) { printf("<FINDVAR> Found in "); dumpln(NAME(parent)); }
      #endif
      if( a ) return a;
    }

  #ifdef DEBUG_FIND_VAR
    printf("<FINDVAR> Search it in parent "); dumpln(NAME(globals));
  #endif
  a = find_local_var( name, globals );
  #ifdef DEBUG_FIND_VAR
    if( a ) { printf("<FINDVAR> Found in "); dumpln(NAME(globals)); }
  #endif
  if( a ) return a;

  #ifdef DEBUG_FIND_VAR
    printf("<FINDVAR> Not found\n");
  #endif
  return NULL; // not found
}
atom_t find_local_runtime_var ( atom_t  name,
int  frame 
)
Parameters:
nameword atom containing the searched name
framestarting frame for the search
Returns:
found var atom or NULL if not found

Searches a variable named name in the the given stack frame. Search is done in the list of variables created at run-time.

If the variable is not found in the runtimers, then search continues with compile-time vars.

{
  atom_t parent;
  atom_t var;

  #ifdef SAFEMODE
    assert( IS_WORD(name) || IS_SUBWORD(name) );
  #endif

  #ifdef DEBUG_FIND_RUNTIME_VAR
    printf("<FIND_LOCAL_RUNTIME_VAR> Search "); dumpln(name);
  #endif

  // first scan variables created at run-time
  parent = *(atom_t*)(frame+BASE_OFFSET_LOCALS);
  var = find_local_var( name, parent );
  #ifdef DEBUG_FIND_RUNTIME_VAR
    if( var ) { printf("<FIND_LOCAL_RUNTIME_VAR> Found runtimer "); dumpln(NAME(var)); }
  #endif
  if( var ) return var;

  // then scan variables created at compile-time
  parent = *(atom_t*)(frame+BASE_OFFSET_PARENT);
  var = find_local_var( name, parent );
  #ifdef DEBUG_FIND_RUNTIME_VAR
    if( var ) { printf("<FIND_LOCAL_RUNTIME_VAR> Found local "); dumpln(NAME(var)); }
  #endif
  if( var ) return var;

  #ifdef DEBUG_FIND_RUNTIME_VAR
    printf("<FIND_LOCAL_RUNTIME_VAR> Not found\n");
  #endif
  return NULL; // not found
}
atom_t find_runtime_var ( atom_t  name,
int  frame 
)
Parameters:
nameword atom containing the searched name
framestarting frame for the search
Returns:
found var atom or NULL if not found
Note:
search is syntax-scope based

Searches a variable named name starting from the given stack frame. Search is done in the list of variables created at run-time.

If the variable is not found in the runtimers, then search continues with compile-time vars.

If still not found, the search moves to the parent frame.

If not found in all frames up to the root, then scan the globals var.

{
  atom_t parent;
  atom_t var;

  #ifdef SAFEMODE
    assert( IS_WORD(name) || IS_SUBWORD(name) );
  #endif

  #ifdef DEBUG_FIND_RUNTIME_VAR
    printf("<FIND_RUNTIME_VAR> Search "); dumpln(name);
  #endif

  // scan parent and its parents
  while( frame )
    {
      // first scan variables created at run-time
      parent = *(atom_t*)(frame+BASE_OFFSET_LOCALS);
      var = find_local_var( name, parent );
      #ifdef DEBUG_FIND_RUNTIME_VAR
        if( var ) { printf("<FIND_RUNTIME_VAR> Found runtimer "); dumpln(NAME(var)); }
      #endif
      if( var ) return var;

      // then scan variables created at compile-time
      parent = *(atom_t*)(frame+BASE_OFFSET_PARENT);
      var = find_local_var( name, parent );
      #ifdef DEBUG_FIND_RUNTIME_VAR
        if( var ) { printf("<FIND_RUNTIME_VAR> Found local "); dumpln(NAME(var)); }
      #endif
      if( var ) return var;

      // exit the loop if we reached the root variable
      if( parent==root ) break;

      // go to upper frame
      frame = *((int*)(frame));
    }

  // the variable is not found, thus now
  // scan the global variables
  var = find_local_var( name, globals );
  #ifdef DEBUG_FIND_RUNTIME_VAR
     if( var ) { printf("<FIND_RUNTIME_VAR> Found global "); dumpln(NAME(var)); }
  #endif
  if( var ) return var;


  #ifdef DEBUG_FIND_RUNTIME_VAR
    printf("<FIND_RUNTIME_VAR> Not found\n");
  #endif
  return NULL; // not found
}
atom_t find_local_var ( atom_t  name,
atom_t  parent 
)
Parameters:
nameword atom containing the searched name
parentvar atom where to start the search
Returns:
found var atom or NULL if not found
Note:
search is syntax-scope based

Searches a variable named name starting from variable parent. If found returns the var atom, otherwise returns NULL. The search scans only the variables parent. It does not scan its parents.

This search schema can find only variables known at the time of compilation. Also, the search is strictly syntax-scope based.

If the parent is a list atom, then just scan its elements (as if this is the LOCALS field of a var)

{
#ifdef SAFEMODE
  assert( IS_WORD(name) || IS_SUBWORD(name) );
  assert( parent );
  assert( IS_VARATOM(parent) || IS_LIST(parent) );
#endif

  atom_t a;

  if( IS_LIST(parent) )
    {
      a = parent;
    }
  else
    {
      if( !DESCR2(parent) ) return NULL;
      a = LOCALS(parent);
      if( !a ) return NULL;
    }

  // scan all elements in the LOCALS
  for( ; IS_NOT_EMPTY(a); a=CDR(a) )
    if( same_words(name,NAME(CAR(a))) )
      {
        return CAR(a); // found
      }

  return NULL; // not found
}
atom_t new_local_var ( atom_t  name,
atom_t  function,
int  quoted 
)
Parameters:
nameword atom for the name of the variable
functionvar atom for the parent of the variable
quotedshows whether the name is quoted
Returns:
var or error atom

Creates a local variable in a function. The input name contains the name of the local variable together with the : or " character (if quoted!=0). If such local variable does not exist in the function, then it is created and returned to the caller. Otherwise an error atom of ERROR_DUPLICATE_INPUT error is returned.

{
  #ifdef SAFE_MODE
  assert( IS_VAR(function) );
  assert( IS_ANY_WORD(name) );
  if( quoted )
    {
      assert( LENGTH(name)>1 );
      assert( *STRING(name)==TEXT(':') || *STRING(name)==TEXT('"') );
    }
  #endif

  atom_t real_name;
  if( quoted )
    real_name = new_subword( name, STRING(name)+1, LENGTH(name)-1 );
  else
    real_name = USE( name );

  if( find_local_var(real_name,function) )
    {
      //printf("THERE IS "); dump(real_name); printf(" IN FUNC "); dumpln(function);
      DEUSE( real_name );
      return new_error( ERROR_DUPLICATE_INPUT, name );
    }

  //printf("CREATED "); dump(real_name); printf(" IN FUNC "); dumpln(function);
  atom_t a = new_var( real_name, function, 1 );
  DEUSE( real_name );
  return a;
}
atom_t copy_local_vars ( int  frame)
Parameters:
framecurrent frame pointer
Returns:
same atom as input

This function is called from the generated code. It copies all local variables of the current frame into the dynamic parent (i.e. caller).

Copying variables consideres these cases:

No Flag Type Action --- --------- ---- ------ 1. primitive * not copied 2. * tag not copied 3. variable normal 4. variable runtime 5. variable else not copied 7. func/cmd normal 8. func/cmd runtime 9. func/cmd external 10. func/cmd internal

{
  // get frame and var atom of the callee
  int callee_frame = frame;
  atom_t callee = *(atom_t*)(callee_frame+BASE_OFFSET_PARENT);
  
  // get frame and var atom of the caller
  int caller_frame = *(int*)(callee_frame+BASE_OFFSET_DYNAMIC);
  atom_t caller = *(atom_t*)(caller_frame+BASE_OFFSET_PARENT);;
    
  //printf( "}->callee = "); dumpln(NAME(callee));
  //printf( "}->caller = "); dumpln(NAME(caller));
  
//#define FLAG_VARIABLE    0x0002
//#define FLAG_FUNCTION    0x0004
//#define FLAG_COMMAND    0x0008

//#define VAR_TYPE_NORMAL    0x00  ///< variable value is in stack
//#define VAR_TYPE_RUNTIME  0x01  ///< variable value is in the variable

  // Copies pure variable var from the callee to the caller.
  // If the variable exists in the caller, only its value
  // is transfered. If the variable does not exist, then
  // it is created as a runtime variable in the caller.
  // If to_atom is null, then there is no target variable
  void copy_var( atom_t from_var, atom_t to_var )
  {
    if( !to_var )
    {
      if( caller==root )
      {
        to_var = new_var( NAME(from_var), globals, 1 ); 
      }
      else
      {
        to_var = new_var( NAME(from_var), caller, 0 ); 
        atom_t* localsp = (atom_t*) (caller_frame + BASE_OFFSET_LOCALS);
        *localsp = new_list( to_var, *localsp ); // attach to other runtimers
      }
      VARTYPE( to_var ) = VAR_TYPE_RUNTIME;
      VALUE( to_var ) = USE( unbound );
    }
    
    //printf("copy "); dump_atom(NAME(PARENT(from_var)),1);
    //printf("."); dump_atom(NAME(from_var),1);
    //printf(" -> "); dump_atom(NAME(PARENT(to_var)),1);
    //printf("."); dump_atom(NAME(to_var),1);
    
    //printf("\n-->from_var=<|"); dump_atom((to_var),1);
    //printf("|>\n-->to_var=<|"); dump_atom((to_var),1);
    //printf("|>\n");
    
    // Continue with copying
    atom_t value;
      
    // get the value from the source variable variable
    SET_FLAGS( to_var, FLAG_VARIABLE );
    if( IS_NORMAL(from_var) )
    {  // CASE 3: value is in the current stack 
      value = *(atom_t*)((char*)callee_frame+OFFSET(from_var));
    }
    else
    {  // CASE 4: value pointed by var's atom
      value = VALUE( from_var );
    }
      
    // put the value in the target variable
    if( IS_NORMAL(to_var) )
    {
      //printf("normal var\n");
      atom_t* varptr = (atom_t*) ((char*)caller_frame + OFFSET( to_var ));
      //printf(" old="); dump_atom(*varptr,1);
      DEUSE( *varptr );
      *varptr = USE( value );
    }
    else
    {
      //printf("runtime var %x %x\n",(unsigned int)to_var,(unsigned int)VALUE(to_var));
      //printf(" old="); dump_atom(VALUE(to_var),1);
      DEUSE( VALUE(to_var) );
      VALUE( to_var ) = USE(value);
    }
  
    //printf(" new="); dump_atom(value,1);
    //printf("\n");
  } //copy_var()

  // Copies function/command var from the callee to the caller.
  // If to_atom is null, then there is no target variable
  void copy_func( atom_t from_var, atom_t to_var )
  {
    // if target does not exist - attach the var to the target parent
    // decrease the level of all static locals and recompile
    if( !to_var )
    {
        to_var = USE( from_var );
        LOCALS( caller ) = new_list( to_var, LOCALS( caller ) );
    }
    else
    {
      // if definitions are incompatible (different number of
      // local parameters) then exit without copying
      if (LARGS( from_var ) != LARGS( to_var ) || RARGS( from_var ) != RARGS( to_var ))
      {
        return;
      }
      
      FLAGS( to_var ) = FLAGS( from_var );
      VARTYPE( to_var ) = VARTYPE( from_var );
      PRIORITY( to_var ) = PRIORITY( from_var );
      ADDRESS( to_var ) = ADDRESS( from_var );

      DEUSE( LOCALS( to_var ) );
      LOCALS( to_var ) = USE( LOCALS( from_var ) );

      DEUSE( DEFINITIONS( to_var ) );
      DEFINITIONS( to_var ) = USE( DEFINITIONS( from_var ) );

      DEUSE( BINARY( to_var ) );
      BINARY( to_var ) = USE( BINARY( from_var ) );
    }
  }

  void copy_var_or_func( atom_t from_var )
  {
    // primitives cannot be copied
    if( IS_PRIMITIVE(from_var) ) return;
    
    // not notmals and not runtimes cannot be copies
    if( !IS_NORMAL(from_var) && !IS_RUNTIME(from_var) ) return;

    // search the destination variable
    atom_t to_var = find_local_runtime_var( NAME(from_var), caller_frame );
    
    // destination var must be non-primitive and (normal or runtime)
    if( to_var )
    {
      if( IS_PRIMITIVE(to_var) ) return;
      if( !IS_NORMAL(to_var) && !IS_RUNTIME(to_var) ) return;
    }
    
    // if variable or function/command then copy the var
    if( IS_VARIABLE( from_var ) ) copy_var( from_var, to_var );
    if( IS_FUNCTION( from_var ) || IS_COMMAND( from_var ) ) copy_func( from_var, to_var );

    return;
  }
  
  atom_t vars;
  
  // first scan variables created at run-time
  vars = *(atom_t*)(callee_frame+BASE_OFFSET_LOCALS);
  for( ; IS_NOT_EMPTY(vars); vars=CDR(vars) ) copy_var_or_func( CAR(vars) );

  // then scan variables created at compile-time
  vars = LOCALS(callee);
  for( ; IS_NOT_EMPTY(vars); vars=CDR(vars) ) copy_var_or_func( CAR(vars) );
}

Variable Documentation


[ HOME | INDEX | ATOMS | VARS | REFERENCE ]
Lhogho Developer's Documentation
Tue Feb 7 2012