Defines
#define	ROOT_VAR_NAME TEXT("%root%")
	name of the root variable
#define	GLOBALS_VAR_NAME TEXT("%globals%")
	name for the globals variable
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
atom_t	new_local_var (atom_t name, atom_t function, int quoted)
	creates a new local var
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_var (atom_t name, atom_t parent)
	searches a local variable
atom_t	find_runtime_var (atom_t name, int static_link)
	searches a variable at runtime
int	need_descr2 (atom_t var)
	creates var descriptor if needed
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
Priority constants
#define	PRIORITY_VAR 6
	priority of variables
#define	PRIORITY_MUL 5
	priority of * and / operators
#define	PRIORITY_ADD 4
	priority of + and - operators
#define	PRIORITY_FUN 3
	priority of functions
#define	PRIORITY_CMP 2
	priority of <, >, =, <= and >= operators
#define	PRIORITY_LOG 1
	priority of and, or and not
#define	PRIORITY_CMD 0
	priproy of commands
#define	PRIORITY_MAX PRIORITY_VAR
	maximal priority
#define	PRIORITY_MIN PRIORITY_CMD
	minimal priority
Fields macros
These macros are used to access var atoms' fields. Details about each macro for each variable type are in Atoms.
#define	OFFSET_DESCR1 8
#define	OFFSET_ADDRESS 12
#define	DESCR1(x) ((x)->unode.a[2])
#define	DESCR2(x) ((x)->unode.a[3])
#define	PARENT(x) (DESCR1(x)->unode.a[0])
#define	NAME(x) (DESCR1(x)->unode.a[2])
#define	ADDRESS(x) (DESCR1(x)->unode.n[3])
#define	OFFSET(x) (DESCR1(x)->unode.n[3])
#define	VALUE(x) (DESCR1(x)->unode.a[3])
#define	LEVEL(x) (DESCR1(x)->unode.b[4])
#define	CTYPE(x) (DESCR1(x)->unode.b[5])
#define	PRIORITY(x) (DESCR1(x)->unode.b[5])
#define	LARGS(x) (DESCR1(x)->unode.b[6])
#define	RARGS(x) (DESCR1(x)->unode.b[7])
#define	DEFINITIONS(x) (DESCR2(x)->unode.a[0])
#define	FULLSOURCE(x) (CAR(DEFINITIONS(x)))
#define	SOURCE(x) (CAR(CDR(DEFINITIONS(x))))
#define	BODY(x) (CAR(CDR(CDR(DEFINITIONS(x)))))
#define	TREE(x) (CAR(CDR(CDR(CDR(DEFINITIONS(x))))))
#define	LOCALS(x) (DESCR2(x)->unode.a[1])
#define	BINARY(x) (DESCR2(x)->unode.a[3])
#define	VARTYPE(x) ((x)->unode.b[5])
#define	VARCLASS(x) ((VARTYPE(x)-VAR_TYPE_EXTERNAL)&0x3F)
Flags
These bitmask flags determine the type of the variable and its properties. The `FLAG_PRIORITY_*` flags are not encoded in the var atom - they are only present in the array with definition of primitives. See also: Flags.
#define	FLAG_PRIMITIVE 0x0001
#define	FLAG_VARIABLE 0x0002
#define	FLAG_FUNCTION 0x0004
#define	FLAG_COMMAND 0x0008

#define	FLAG_CAN_BE_UNARY 0x0010
#define	FLAG_INFINITE_ARGS 0x0020
#define	FLAG_MAY_SKIP_LAST_ARG 0x0040
#define	FLAG_PROCESS_ARGS 0x0080
#define	FLAG_PUSH_PARENT 0x0100
#define	FLAG_SET_ONE_VAR 0x0200
#define	FLAG_SET_ALL_VARS 0x0400
#define	FLAG_MAY_HAVE_EXTRA_ARG 0x0800
#define	FLAG_PUSH_FRAME 0x1000
#define	FLAG_PRINT_VARS 0x2000
#define	FLAG_EQUAL_VARS 0x4000
#define	FLAG_PUSH_MODE 0x8000
#define	ALL_VAR_FLAGS 0xFFFF

Types
These values determine the type of a variable. A variable could belong to only one type/
#define	VAR_TYPE_NORMAL 0x00
	variable value is in stack
#define	VAR_TYPE_RUNTIME 0x01
	variable value is in the variable
#define	VAR_TYPE_TAG 0x02
	variable is tag
#define	VAR_TYPE_EXTERNAL 0x80
	0x80-0xBF variable is an external function
#define	VAR_TYPE_INTERNAL 0xC0
	0xC0-0xFF variable is an internal function
#define	FLAG_PRIORITY_MUL 0x010000
#define	FLAG_PRIORITY_ADD 0x020000
#define	FLAG_PRIORITY_LOG 0x040000
#define	FLAG_PRIORITY_CMP 0x080000
Offsets
Base offsets determine the initial offset of variables relative to the current stack frame. Function parameters start from offset BASE_OFFSET_PARAMS and go upward. Function local variablse start from offset BASE_OFFSET_LOCALS and go downward.
#define	BASE_OFFSET_PARAMS 12
	base offset for parameters
#define	BASE_OFFSET_DYNAMIC 0
	base offset for the dynamic pointer
#define	BASE_OFFSET_STATIC -4
	base offset for the static pointer
#define	BASE_OFFSET_PARENT -8
	base offset for the parent atom
#define	BASE_OFFSET_REPEATCHAIN -12
	base offset for repeat-chain
#define	BASE_OFFSET_TEST -16
	base offset for test
#define	BASE_OFFSET_LOCALS -20
	base offset for locals
Constants
String constants are used to initialize some system-defined variables.
#define	LOGO_VERSION TEXT("0.0")
	Logo version.
#define	LOGO_DIALECT TEXT("Lhogho")
	Logo dialect.
Testers
#define	IS_PRIMITIVE(x) GET_FLAGS(x,FLAG_PRIMITIVE)
#define	IS_VARIABLE(x) GET_FLAGS(x,FLAG_VARIABLE)
#define	IS_FUNCTION(x) GET_FLAGS(x,FLAG_FUNCTION)
#define	IS_COMMAND(x) GET_FLAGS(x,FLAG_COMMAND)
#define	IS_VARATOM(x) (ID(x)==VAR_ID)
#define	IS_UNBOUND(x) ((x)==unbound)
#define	IS_STOPPED(x) ((x)==stopped)
#define	IS_GLOBAL(x) (PARENT(x)==globals)
#define	IS_NORMAL(x) (VARTYPE(x)==VAR_TYPE_NORMAL)
#define	IS_TAG(x) (VARTYPE(x)==VAR_TYPE_TAG)
#define	IS_RUNTIME(x) (VARTYPE(x)==VAR_TYPE_RUNTIME)
#define	IS_EXTERNAL(x) ((VARTYPE(x)&0xC0)==VAR_TYPE_EXTERNAL)
#define	IS_INTERNAL(x) ((VARTYPE(x)&0xC0)==VAR_TYPE_INTERNAL)

Define Documentation

#define PRIORITY_VAR 6

#define PRIORITY_MUL 5

#define PRIORITY_ADD 4

#define PRIORITY_FUN 3

#define PRIORITY_CMP 2

#define PRIORITY_LOG 1

#define PRIORITY_CMD 0

#define PRIORITY_MAX PRIORITY_VAR

#define PRIORITY_MIN PRIORITY_CMD

#define OFFSET_DESCR1 8

#define OFFSET_ADDRESS 12

#define DESCR1 ( x ) ((x)->unode.a[2])

#define DESCR2 ( x ) ((x)->unode.a[3])

#define PARENT ( x ) (DESCR1(x)->unode.a[0])

#define NAME ( x ) (DESCR1(x)->unode.a[2])

#define ADDRESS ( x ) (DESCR1(x)->unode.n[3])

#define OFFSET ( x ) (DESCR1(x)->unode.n[3])

#define VALUE ( x ) (DESCR1(x)->unode.a[3])

#define LEVEL ( x ) (DESCR1(x)->unode.b[4])

#define CTYPE ( x ) (DESCR1(x)->unode.b[5])

#define PRIORITY ( x ) (DESCR1(x)->unode.b[5])

#define LARGS ( x ) (DESCR1(x)->unode.b[6])

#define RARGS ( x ) (DESCR1(x)->unode.b[7])

#define DEFINITIONS ( x ) (DESCR2(x)->unode.a[0])

#define FULLSOURCE ( x ) (CAR(DEFINITIONS(x)))

#define SOURCE ( x ) (CAR(CDR(DEFINITIONS(x))))

#define BODY ( x ) (CAR(CDR(CDR(DEFINITIONS(x)))))

#define TREE ( x ) (CAR(CDR(CDR(CDR(DEFINITIONS(x))))))

#define LOCALS ( x ) (DESCR2(x)->unode.a[1])

#define BINARY ( x ) (DESCR2(x)->unode.a[3])

#define VARTYPE ( x ) ((x)->unode.b[5])

#define VARCLASS ( x ) ((VARTYPE(x)-VAR_TYPE_EXTERNAL)&0x3F)

#define FLAG_PRIMITIVE 0x0001

#define FLAG_VARIABLE 0x0002

#define FLAG_FUNCTION 0x0004

#define FLAG_COMMAND 0x0008

#define FLAG_CAN_BE_UNARY 0x0010

#define FLAG_INFINITE_ARGS 0x0020

#define FLAG_MAY_SKIP_LAST_ARG 0x0040

#define FLAG_PROCESS_ARGS 0x0080

#define FLAG_PUSH_PARENT 0x0100

#define FLAG_SET_ONE_VAR 0x0200

#define FLAG_SET_ALL_VARS 0x0400

#define FLAG_MAY_HAVE_EXTRA_ARG 0x0800

#define FLAG_PUSH_FRAME 0x1000

#define FLAG_PRINT_VARS 0x2000

#define FLAG_EQUAL_VARS 0x4000

#define FLAG_PUSH_MODE 0x8000

#define ALL_VAR_FLAGS 0xFFFF

#define VAR_TYPE_NORMAL 0x00

#define VAR_TYPE_RUNTIME 0x01

#define VAR_TYPE_TAG 0x02

#define VAR_TYPE_EXTERNAL 0x80

#define VAR_TYPE_INTERNAL 0xC0

#define FLAG_PRIORITY_MUL 0x010000

#define FLAG_PRIORITY_ADD 0x020000

#define FLAG_PRIORITY_LOG 0x040000

#define FLAG_PRIORITY_CMP 0x080000

#define BASE_OFFSET_PARAMS 12

#define BASE_OFFSET_DYNAMIC 0

#define BASE_OFFSET_STATIC -4

#define BASE_OFFSET_PARENT -8

#define BASE_OFFSET_REPEATCHAIN -12

#define BASE_OFFSET_TEST -16

#define BASE_OFFSET_LOCALS -20

#define LOGO_VERSION TEXT("0.0")

#define LOGO_DIALECT TEXT("Lhogho")

#define IS_PRIMITIVE ( x ) GET_FLAGS(x,FLAG_PRIMITIVE)

#define IS_VARIABLE ( x ) GET_FLAGS(x,FLAG_VARIABLE)

#define IS_FUNCTION ( x ) GET_FLAGS(x,FLAG_FUNCTION)

#define IS_COMMAND ( x ) GET_FLAGS(x,FLAG_COMMAND)

#define IS_VARATOM ( x ) (ID(x)==VAR_ID)

#define IS_UNBOUND ( x ) ((x)==unbound)

#define IS_STOPPED ( x ) ((x)==stopped)

#define IS_GLOBAL ( x ) (PARENT(x)==globals)

#define IS_NORMAL ( x ) (VARTYPE(x)==VAR_TYPE_NORMAL)

#define IS_TAG ( x ) (VARTYPE(x)==VAR_TYPE_TAG)

#define IS_RUNTIME ( x ) (VARTYPE(x)==VAR_TYPE_RUNTIME)

#define IS_EXTERNAL ( x ) ((VARTYPE(x)&0xC0)==VAR_TYPE_EXTERNAL)

#define IS_INTERNAL ( x ) ((VARTYPE(x)&0xC0)==VAR_TYPE_INTERNAL)

#define ROOT_VAR_NAME TEXT("%root%")

#define GLOBALS_VAR_NAME TEXT("%globals%")

Function Documentation

void init_vars ( )

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 );
}

void finit_vars ( )

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:

name	word atom for the name of the variable
parent	var atom for the parent of the variable
attach	1=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;
}

atom_t new_local_var	(	atom_t	name,
		atom_t	function,
		int	quoted
	)

Parameters:

name	word atom for the name of the variable
function	var atom for the parent of the variable
quoted	shows 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;
}

void delete_var ( atom_t a )

Parameters:

a	atom 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:

a	atom to dump
level	dump 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:

name	word atom containing the searched name
parent	var 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_var	(	atom_t	name,
		atom_t	parent
	)

Parameters:

name	word atom containing the searched name
parent	var 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 find_runtime_var	(	atom_t	name,
		int	frame
	)

Parameters:

name	word atom containing the searched name
frame	starting 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
}

int need_descr2 ( atom_t var )

Parameters:

var	var 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;
}

void copy_local_vars ( int frame )

Parameters:

frame current 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) );
}