Lhogho  0.0.027
Defines | Functions | Variables
compiler.c File Reference

Defines

#define SRC_EXT_COUNT   (sizeof source_extensions)/(sizeof source_extensions[0])
#define SRC_EXT   (source_extensions[i])
#define BUF_SIZE   1024
#define RETURN_NO_CHECK(INSTR)
#define RETURN_NO_CHECK_EL(INSTR)
#define RETURN_CHECK(INSTR)

Functions

atom_t compile_expr (context_t *ctx, atom_t lisp, int mode)
 compiles expression or constant
atom_t compile_block (context_t *ctx, atom_t lisp, int mode)
 compiles block of statements
atom_t compile_if (context_t *ctx, atom_t source, int mode)
 compiles IF statement
atom_t compile_repeat (context_t *ctx, atom_t source)
 compiles REPEAT statement
atom_t compile_while (context_t *ctx, atom_t source, int is_while, int is_do)
 compiles WHILE statement
atom_t compile_forever (context_t *ctx, atom_t source)
 compiles FOREVER statement
atom_t compile_catch (context_t *ctx, atom_t source, int mode)
 compiles CATCH statement
atom_t compile_tag (context_t *ctx, atom_t source)
 compiles TAG statement
atom_t compile_goto (context_t *ctx, atom_t source, atom_t var)
 compiles GOTO statement
atom_t compile_iftest (context_t *ctx, atom_t source, int criteria)
atom_t compile_for (context_t *ctx, atom_t source)
 compiles FOR statement
void init_compiler (outter_t outter, inner_t inner, inner_eof_t inner_eof)
 initializes the compiler
void finit_compiler ()
 finalizes the compiler
int compile_from_options ()
 compiles according to options
atom_t compile_to_file ()
 compiles into executable file
atom_t instruction_list (atom_t data)
 ensured that input is a list in brackets
int run_function (atom_t function)
 runs the compiled code of a function
int run_source (chars_t source)
 compiles and runs source code
atom_t compile_function (atom_t func, int mode, int is_macro)
 compiles a function
atom_t compile_external_function (atom_t func)
 compiles an external function
atom_t compile_internal_function (atom_t func, int static_link)
 compiles an internal function
int is_constant (atom_t lisp)
 determines whether lisp is a constant
int is_reference (atom_t lisp)
 determines whether lisp is a reference
atom_t compile_lisp_const (context_t *ctx, atom_t lisp)
 compiles constant
atom_t compile_local (context_t *ctx, atom_t source, int *processed)
 compiles LOCAL statement
atom_t compile_make (context_t *ctx, atom_t source, int is_name, int *processed)
 compiles MAKE statement
atom_t compile_output (context_t *ctx, atom_t source)
 compiles OUTPUT statement
atom_t compile_maybeoutput (context_t *ctx, atom_t source)
 compiles MAYBEOUTPUT statement
atom_t compile_stop (context_t *ctx, atom_t source)
 compiles STOP statement
atom_t compile_test (context_t *ctx, atom_t source, int criteria)
 compiles IFTRUE and IFFALSE statements
atom_t compile_lisp_reference (context_t *ctx, atom_t source)
 compiles reference

Variables

int running_compiled_code
 indicate whether generated code is currently running
int compiling_code
 indicate whether source code is currently compiling
char * source_extensions [] = { ".lgo", ".log", ".lg", ".logo", ".lho", ".lhogho" }

Define Documentation

#define SRC_EXT_COUNT   (sizeof source_extensions)/(sizeof source_extensions[0])
#define SRC_EXT   (source_extensions[i])
#define BUF_SIZE   1024
#define RETURN_NO_CHECK (   INSTR)
Value:
{                 \
    result = INSTR;           \
    needs_check = 0;          \
    goto finalize;            \
  }
#define RETURN_NO_CHECK_EL (   INSTR)
Value:
{                 \
    result = INSTR;           \
    if( !IS_ERROR(result) ) result = empty_list;\
    needs_check = 0;          \
    goto finalize;            \
  }
#define RETURN_CHECK (   INSTR)
Value:
{                 \
    result = INSTR;           \
    needs_check = 1;          \
    goto finalize;            \
  }

Function Documentation

atom_t compile_expr ( context_t *  ctx,
atom_t  lisp,
int  mode 
)
Parameters:
ctxcompilation context
lispstatement to compile
modecompilation mode (COMPILE_AS_FUNC/COMPILE_AS_PROC)
Returns:
empty_list, unbound or error atom

Compiles a single expression or constant. If needed calls itself recursively to process nested expressions. Expression result is in the stack.

Depending on mode the result is checked with rt_cmdchk(), rt_funchk() or rt_exprchk().

If the result of compile_expr is empty list, then the expression is a constant which is left in the stack. The caller may want to pop it in EAX register. 

{
#define RETURN_NO_CHECK(INSTR)         \
  {                  \
    result = INSTR;           \
    needs_check = 0;          \
    goto finalize;            \
  }
#define RETURN_NO_CHECK_EL(INSTR)      \
  {                  \
    result = INSTR;           \
    if( !IS_ERROR(result) ) result = empty_list;\
    needs_check = 0;          \
    goto finalize;            \
  }
#define RETURN_CHECK(INSTR)         \
  {                  \
    result = INSTR;           \
    needs_check = 1;          \
    goto finalize;            \
  }

  atom_t orig_lisp = lisp;
  lisp = CAR(lisp);

  int needs_check = 1;
  atom_t result = unbound;

  #ifdef DEBUG_COMPILE
    printf("<COMPILE> Compile expression: "); dumpln(lisp);
  #endif

  // remove extra parentheses
  if( IS_LIST(lisp) )
    if( !IS_EMPTY(lisp) )
      if( IS_EXPRESSION(lisp) )
        while( IS_LIST(CAR(lisp)) && IS_EXPRESSION(CAR(lisp)) && IS_EMPTY(CDR(lisp)) )
          lisp = CAR(lisp);

  #ifdef DEBUG_COMPILE
    printf("<COMPILE> Normalized expression: "); dumpln(lisp);
    if( IS_LIST(lisp) && IS_EXTENDED(lisp) )
      {
   printf("<COMPILE>It's source is: |");
   dump(POS(lisp));
   printf("|\n");
      }
  #endif

  // if the source is a constant, then just push it
  if( is_constant(lisp) )
    {
      if( mode==COMPILE_AS_PROC )
      {
        if( IS_EXTENDED(lisp) && !IS_UNBOUND(POS(lisp)) )
          return new_error( ERROR_UNUSED_VALUE, POS(lisp) );
        else
        if( IS_EXTENDED(orig_lisp) && !IS_UNBOUND(POS(orig_lisp)) )
          return new_error( ERROR_UNUSED_VALUE, POS(orig_lisp) );
        else
          return new_error( ERROR_UNUSED_VALUE, lisp );
      }
      RETURN_NO_CHECK_EL( compile_lisp_const(ctx,lisp) );
    }

  // test whether the source is a reference
  if( is_reference( lisp ) )
    {
      if( mode==COMPILE_AS_PROC )
        return new_error( ERROR_UNUSED_VALUE, lisp );
      RETURN_NO_CHECK_EL( compile_lisp_reference(ctx,lisp) );
    }

  // the source is not a constant and cannot be just pushed
  INFO( "" );
  INFO( "code for %a", lisp );
 
  // find the main function of the expression
  // it must be known variable
  atom_t varname = CAR( lisp );
  #ifdef SAFEMODE
    assert( IS_ANY_WORD(varname) );
  #endif

  if( LENGTH(varname)==1  && *STRING(varname)==TEXT('"') )
  {
    return new_error( ERROR_DO_NOT_KNOW, lisp );
  }
  
  atom_t var = find_var( varname, ctx->parent );
  #ifdef SAFEMODE
    assert( var );
  #endif

  // variables cannot be commands and procedures
  if( IS_VARIABLE(var) )
    return new_error( ERROR_NOT_A_FUNCTION, lisp );

  // commands do not return values
  if( (mode==COMPILE_AS_FUNC) && !IS_FUNCTION(var) ) 
    return new_error( ERROR_MISSING_VALUE, lisp );

  //printf("var="); dumpln(NAME(var));

  int addr = ADDRESS(var);
  #ifdef SAFEMODE
    if( IS_PRIMITIVE(var) ) assert( addr );
  #endif

  // dump source which is about to be executed or evaluated
  #ifdef ADVANCED
  if( OPTION_RUNTIME )
    {
      asm_dump_source( ctx, lisp );
    }
  #endif


  // SPECIAL COMPILATION CASES
  {
    // 0. _int3_
    if( addr==(int)rt_int3 )
      {
        asm_int_3( ctx );
        RETURN_NO_CHECK( unbound );
      }
    
    // 1. local <name>
    if( addr==(int)rt_local )
      {
        int processed;
        result = compile_local( ctx, lisp, &processed );
        if( processed ) RETURN_NO_CHECK( result );
      }

    // 2. make <name> <value>
    if( addr==(int)rt_make )
      {
        int processed;
        result = compile_make( ctx, lisp, 0, &processed );
        //printf("processed make=%d\n",processed);
        if( processed ) RETURN_NO_CHECK( result );
      }

    // 3. name <value> <name>
    if( addr==(int)rt_name )
      {
        int processed;
        result = compile_make( ctx, lisp, 1, &processed );
        if( processed ) RETURN_NO_CHECK( result );
      }

    // 4a. output <value>
    if( addr==(int)rt_output )
      RETURN_NO_CHECK( compile_output(ctx,lisp) );

    // 4b. maybeoutput <value>
    if( addr==(int)rt_maybeoutput )
      RETURN_NO_CHECK( compile_maybeoutput(ctx,lisp) );

    // 5. stop
    if( addr==(int)rt_stop )
      RETURN_NO_CHECK( compile_stop(ctx,lisp) );

    // 6. if
    if( addr==(int)rt_if )
      RETURN_NO_CHECK( compile_if(ctx,lisp,mode) );

    // 7. repeat
    if( addr==(int)rt_repeat )
      RETURN_NO_CHECK( compile_repeat(ctx,lisp) );

    // 8. forever
    if( addr==(int)rt_forever )
      RETURN_NO_CHECK( compile_forever(ctx,lisp) );

    // 9. while
    if( addr==(int)rt_while )
      RETURN_NO_CHECK( compile_while(ctx,lisp,1,0) );

    // 10. until
    if( addr==(int)rt_until )
      RETURN_NO_CHECK( compile_while(ctx,lisp,0,0) );

    // 11. do.while
    if( addr==(int)rt_dowhile )
      RETURN_NO_CHECK( compile_while(ctx,lisp,1,1) );

    // 12. do.until
    if( addr==(int)rt_dountil )
      RETURN_NO_CHECK( compile_while(ctx,lisp,0,1) );

    // 13. catch
    if( addr==(int)rt_catch )
      RETURN_CHECK( compile_catch(ctx,lisp,mode) );

    // 14. tag
    if( addr==(int)rt_tag )
      RETURN_NO_CHECK( compile_tag(ctx,lisp) );

    // 15. goto
    if( addr==(int)rt_goto )
      RETURN_NO_CHECK( compile_goto(ctx,lisp,var) );

    // 16. iftrue
    if( addr==(int)rt_iftrue )
      RETURN_NO_CHECK( compile_test(ctx,lisp,1) );

    // 17. iffalse
    if( addr==(int)rt_iffalse )
      RETURN_NO_CHECK( compile_test(ctx,lisp,0) );

    // 18. for
    if( addr==(int)rt_for )
      RETURN_NO_CHECK( compile_for(ctx,lisp) );

  }
  // END OF SPECIAL COMPILATION CASES


  if( GET_FLAGS(var,FLAG_PUSH_MODE) )
    asm_push_mode( ctx, mode );

  if( GET_FLAGS(var,FLAG_PUSH_FRAME) )
    asm_push_frame( ctx );

  int params = 0;
  atom_t x;
  atom_t y;
  if( !IS_PRIMITIVE(var) && GET_FLAGS(var,FLAG_INFINITE_ARGS) )
    {
      //printf("<COMPILE> Compile func: "); dumpln(NAME(var));
      //printf("<COMPILE>  LARGS=%d RARGS=%d\n",LARGS(var),RARGS(var));

      // skip number of compulsory params
      int skip;
      x = CDR(lisp);
      for( skip = LARGS(var)+RARGS(var); skip; skip-- )
   {
     if( IS_NOT_EMPTY(x) ) x = CDR(x);
   }
      // process all extra parameters
      for( ; IS_NOT_EMPTY(x); x=CDR(x) )
   {
          #ifdef DEBUG_COMPILE
     printf("<COMPILE> Compile parameter: "); dumpln(CAR(x));
          #endif
     y = compile_expr( ctx, x, COMPILE_AS_FUNC );
     if( IS_ERROR(y) ) return y;
     params++;
   }
      // process compulsory params
      x = CDR(lisp);
      for( skip = LARGS(var)+RARGS(var); skip; skip-- )
   {
     if( IS_NOT_EMPTY(x) )
       {
              #ifdef DEBUG_COMPILE
         printf("<COMPILE> Compile parameter: "); dumpln(CAR(x));
              #endif
         y = compile_expr( ctx, x, COMPILE_AS_FUNC );
         if( IS_ERROR(y) ) return y;
         x = CDR(x);
       }
     else
       {
         // Compile dummy parameter
         asm_push_atom( ctx, empty_list );
       }
          params++;
   }
    }
  else
    {
      for( x=CDR(lisp); IS_NOT_EMPTY(x); x=CDR(x) )
   {
          #ifdef DEBUG_COMPILE
     printf("<COMPILE> Compile parameter: "); dumpln(CAR(x));
          #endif
     y = compile_expr( ctx, x, COMPILE_AS_FUNC );
     if( IS_ERROR(y) ) return y;
     params++;
   }
    }

  asm_call_atom( ctx, var, params );

  int i;
  for( i=params-1; i>=0; i-- )
    {
      asm_pop_atom( ctx );
    }

  if( GET_FLAGS(var,FLAG_PUSH_FRAME) )
    asm_pop_frame( ctx );

  if( GET_FLAGS(var,FLAG_PUSH_MODE) )
    asm_pop_dummy( ctx );

  // special case for RUN, RUNMACRO and RUNRESULT - they return
  // a var atom containing the actual code to execute.
  if( addr==(int)rt_run )       { asm_run_epilogue( ctx ); }
  if( addr==(int)rt_runmacro )  { asm_run_epilogue( ctx ); }
  if( addr==(int)rt_runresult ) { asm_runresult_epilogue( ctx ); }

  asm_push_result( ctx );
  //disasm_atom( ctx, NAME(var) );

 finalize:
  if( needs_check )
    {
      if( mode==COMPILE_AS_FUNC ) asm_result_func( ctx, lisp );
      if( mode==COMPILE_AS_PROC ) asm_result_proc( ctx, lisp );
      if( mode==COMPILE_AS_UNKNOWN ) asm_result_unknown( ctx, lisp );
    }
  return result;
}
atom_t compile_block ( context_t *  ctx,
atom_t  lisp,
int  mode 
)
Parameters:
ctxcompilation context
lispstatements to compile
modecompilation mode (COMPILE_AS_macro)
Returns:
empty list or error atom

Compiles a block of expressions. If mode is COMPILE_AS_UNKNOWN then the number of expressions determines how to compile. If the number is >1, then compile as procedure. 

{
  //printf("compile_block "); dumpln(lisp);
  //printf("mode=%d (func=%d cmd=%d unknown=%d)\n",mode,COMPILE_AS_FUNC,COMPILE_AS_PROC,COMPILE_AS_UNKNOWN);

  if( (mode==COMPILE_AS_FUNC) && IS_NOT_EMPTY(CDR(lisp)) )
    return new_error( ERROR_CROWDED_EXPRESSION, CDR(lisp) );

  if( mode==COMPILE_AS_UNKNOWN )
    if( IS_NOT_EMPTY(lisp) && IS_NOT_EMPTY(CDR(lisp)) )
   mode = COMPILE_AS_PROC;

  // there is a word
  if( IS_ANY_WORD(lisp) )
  {
      return new_error(ERROR_NOT_A_LIST_CONST,lisp);
  }
  
  // there is a lisp which is not produced by
  // a constant list
  if( !GET_FLAGS(lisp,FLAG_WAS_LIST_CONST) )
  {
      return new_error(ERROR_NOT_A_LIST_CONST,lisp);
  }
  
  atom_t x;
  for( x=lisp; IS_NOT_EMPTY(x); x=CDR(x) )
    {
      #ifdef DEBUG_COMPILE
        printf("<COMPILE> Compile command: "); dumpln(CAR(x));
      #endif

      atom_t y = compile_expr( ctx, x, mode );
      if( IS_ERROR(y) ) return y;

      // do not leave results in the stack
      if( IS_EMPTY(y) && mode==COMPILE_AS_UNKNOWN )
        asm_pop_result( ctx );

      #ifdef DEBUG_COMPILE
        printf("<COMPILE> Command compiled!\n");
      #endif
    }

  if( IS_EMPTY(lisp) )
    {
      if( mode==COMPILE_AS_FUNC )
   {
     asm_empty_body( ctx );
     asm_push_result( ctx );
   }
    }
  return unbound;
}
atom_t compile_if ( context_t *  ctx,
atom_t  source,
int  mode 
)
Parameters:
ctxcompilation context
sourceIF's source
modecompilation mode (COMPILE_AS_... macro)
Returns:
unbound or error atom

Compiles an if statement. The generated code depends on the parameters - whether they are constants or expressions. At the end of execution of generated code the result of if should be in the stack (the result is either error atom or unbound atom). 

{
  atom_t params = CDR(source);
  atom_t condition_src = params;
  atom_t condition = CAR(params);
  atom_t then_lisp = instruction_list(CAR(CDR(params)));
  atom_t else_lisp = instruction_list(CAR(CDR(CDR(params))));

  int has_else = !IS_EMPTY(else_lisp);

  if( mode==COMPILE_AS_FUNC && !has_else )
    return( new_error( ERROR_MISSING_RIGHTS, source ) );

  int branch = 0;
  int ifend = 0;

  //printf("IF STATEMENT\n");
  //printf("  COND="); dumpln(condition);
  //printf("  THEN="); dumpln(then_lisp);
  //printf("  ELSE="); dumpln(else_lisp);

  // compile condition of IF
  atom_t y = compile_expr( ctx, condition_src, COMPILE_AS_FUNC );
  if( IS_ERROR(y) ) return y;

  // add checker for boolean value
  asm_boolean( ctx, condition ); 
  branch = asm_if_prologue( ctx );

  // compile THEN of IF
  asm_label( ctx, TEXT("$then") );
  y = compile_block( ctx, then_lisp, mode );
  if( IS_ERROR(y) ) return y;
  if( has_else )
    ifend = asm_if_epilogue( ctx );
  asm_fix( ctx, branch );

  // compile ELSE of IF
  asm_label( ctx, TEXT("$else") );
  if( has_else )
    {
      y = compile_block( ctx, else_lisp, mode );
      if( IS_ERROR(y) ) return y;
      asm_fix( ctx, ifend );
      asm_label( ctx, TEXT("$ifend") );
    }

  if( mode==COMPILE_AS_PROC )
    asm_adjust_result( ctx );

  return unbound;
}
atom_t compile_repeat ( context_t *  ctx,
atom_t  source 
)
Parameters:
ctxcompilation context
sourceREPEAT's source
Returns:
unbound or error atom

Compiles a repeat statement. The generated code depends on the first parameter of repeat - if it is a constant, then a shorter code is generated. If it is an expression, then the code should contain instructions for calculating the number of repetitions.

At the end of execution of generated code the result of repeat should be in the stack (the result is either error atom or unbound atom). 

{
  atom_t params = CDR(source);
  atom_t repcount_src = params;
  atom_t repcount = CAR(params);
  atom_t commands_lisp = CAR(CDR(params));

  int branch;
  int branch2 = -1;

  if( IS_LIST(repcount) )
    {
    try_expr:
      // REPEAT {expr} [...]
      branch = 0;

      atom_t y = compile_expr( ctx, repcount_src, COMPILE_AS_FUNC );
      if( IS_ERROR(y) ) return y;

      branch = asm_repeat_prologue_expr( ctx, repcount, &branch2 );
    }
  else
    {
      // REPEAT {const} [...]
      int64_t cnt;
      if( !atom_to_int( repcount, &cnt ) )
   goto try_expr;
   // return new_error_atom( ERROR_NOT_AN_INTEGER, repcount );

      if( cnt==0 )
   return unbound;

      if( cnt>INT_MAX )
   return new_error( ERROR_TOO_BIG_NUMBER, repcount );

      if( cnt<1 )
   return new_error( ERROR_TOO_SMALL_NUMBER, repcount );

      branch = asm_repeat_prologue_const( ctx, cnt );
    }

  atom_t y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
  if( IS_ERROR(y) ) return y;

  asm_repeat_epilogue( ctx, branch, branch2 );

  return unbound;
}
atom_t compile_while ( context_t *  ctx,
atom_t  source,
int  is_while,
int  is_do 
)
Parameters:
ctxcompilation context
sourceWHILE's source
is_whilewhile=1, until=0
is_dodo.while/do.until=1, while/until=0
Returns:
unbound or error atom

Compiles a while or a until statement. If the value of is_while is !0, then generated code is for while. If it is 0, then the code is for repeat. If is_do is 1, then parameters must be swapped as in do.while and do.until. 

{
  atom_t condition_src;
  //atom_t condition_lisp;
  atom_t commands_lisp;
  if( is_do )
    {
      condition_src = CDR(CDR(source));
      commands_lisp  = CAR(CDR(source));
    }
  else
    {
      condition_src = CDR(source);
      commands_lisp  = CAR(CDR(CDR(source)));
    }
  //condition_lisp = CAR(condition_src);

  //printf("condition = "); dumpln(condition_lisp);
  //printf("commands  = "); dumpln(commands_lisp);

  int loop_branch = asm_while_prologue( ctx, is_while, is_do );

  if( is_do )
  {
      atom_t y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
      if( IS_ERROR(y) ) return y;
  }

  atom_t x = compile_expr( ctx, condition_src, COMPILE_AS_FUNC );
  if( IS_ERROR(x) ) return x;

  int skip_branch = asm_while_inlogue( ctx, commands_lisp, is_while );

  if( !is_do )
  {
      atom_t y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
      if( IS_ERROR(y) ) return y;
  }

  asm_while_epilogue( ctx, loop_branch, skip_branch, is_while );

  return unbound;
}
atom_t compile_forever ( context_t *  ctx,
atom_t  source 
)
Parameters:
ctxcompilation context
sourceFOREVER's source
Returns:
unbound or error atom

Compiles a forever statement. 

{
  atom_t commands_lisp = CAR(CDR(source));

  int branch = asm_forever_prologue( ctx );

  atom_t y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
  if( IS_ERROR(y) ) return y;

  asm_forever_epilogue( ctx, branch );

  return unbound;
}
atom_t compile_catch ( context_t *  ctx,
atom_t  source,
int  mode 
)
Parameters:
ctxcompilation context
sourceCATCH's source
modecompilation mode (COMPILE_AS_... macro)
Returns:
empty_list or error atom

Compiles a catch statement. The generated code executes the commands and catches forced exits. If they are caused by a throw with the same tag, then the exits are masked. 

{
  //printf("commands="); dumpln(source);
  atom_t params = CDR(source);
  atom_t tag_src = params;
  atom_t commands = CAR(CDR(params));

  // generate catch trampoline (prologue changes exit_addr)
  int old_exit_addr = ctx->exit_addr;
  int branch = asm_catch_prologue( ctx );

  // compile catch body
  atom_t y;
  y = compile_block( ctx, commands, mode );
  if( IS_ERROR(y) ) return y;

  // generate catch prologue and restore exit_addr
  ctx->exit_addr = old_exit_addr;

  // compile tag
  asm_label( ctx, TEXT("exit_catch:") );
  asm_fix( ctx, branch );
  //asm_int_3( ctx );
  if( mode==COMPILE_AS_PROC )
    asm_push_result( ctx );
  else
    asm_set_output_status( ctx, 0 );
  y = compile_expr( ctx, tag_src, COMPILE_AS_FUNC );
  if( IS_ERROR(y) ) return y;
  asm_catch_epilogue( ctx );
  //asm_exit_if_output( ctx );
  return empty_list;
}
atom_t compile_tag ( context_t *  ctx,
atom_t  source 
)
Parameters:
ctxcompilation context
sourceTAG's source
Returns:
unbound or error atom

Compiles a tag statement. Creates a new variable of type VAR_TYPE_TAG. 

{
  atom_t tag = CAR(CDR(source));

  if( !IS_ANY_WORD(tag) )
    return new_error( ERROR_NOT_A_WORD, tag );

  tag = new_subword( tag, STRING(tag)+1, LENGTH(tag)-1 );

  // remember the current position in generated code
  // only suring the first pass
  if( !ctx->generate )
    {
      atom_t var = new_var( tag, ctx->parent, 1 );
      VARTYPE( var ) = VAR_TYPE_TAG;
      VALUE( var ) = new_integer( ctx->size );
      SET_FLAGS( var, FLAG_VARIABLE );
    }
  else
    {
      if( OPTION_ASSEMBLER ) asm_label( ctx, STRING(tag) );
    }

  DEUSE( tag );
  return unbound;
}
atom_t compile_goto ( context_t *  ctx,
atom_t  source,
atom_t  var 
)
Parameters:
ctxcompilation context
sourceGOTO's source
varGOTO's var atom
Returns:
unbound or error atom

Compiles a goto statement. Creates code which searches in real-time for tag named as the input and makes jump to it.

If the input is a constant word, then find taget address at compile-time. 

{
  atom_t target_src = CDR(source);
  atom_t target = CAR(target_src);

  //printf("target="); dumpln(target);

  // try to find whether the target is known at compile-time
  if( IS_ANY_WORD(target)
      && LENGTH(target)>1
      && *STRING(target)==TEXT('"') )
    {
    
      // We have direct GOTO - i.e. we know the target's name
      atom_t real_name = new_subword( target, STRING(target)+1, LENGTH(target)-1 );
      atom_t var = find_local_var( real_name, ctx->parent );
      DEUSE( real_name );

      // test whether the target exists during
      // the second pass of the compilation
      if( ctx->generate && (!var || !IS_TAG(var)) )
   {
     return new_error( ERROR_NOT_A_TAG, target );
   }
      asm_goto( ctx, var );
      return unbound;

    }

  // the target is not a word-constant

  asm_goto_prologue( ctx, target );    // pushes target's source

  // prepare tag
  atom_t y = compile_expr( ctx, target_src, COMPILE_AS_FUNC );
  if( IS_ERROR(y) ) return y;

  asm_call_atom( ctx, var, 1 );
  asm_pop_atom( ctx ); // pop tag
  asm_pop_dummy ( ctx ); // pop source
  asm_goto_epilogue( ctx, target );
  return unbound;
}
atom_t compile_iftest ( context_t *  ctx,
atom_t  source,
int  criteria 
)
atom_t compile_for ( context_t *  ctx,
atom_t  source 
)
Parameters:
ctxcompilation context
sourceFOR's source
Returns:
unbound or error atom

Compiles a for statement. 

{
  atom_t name = CAR(CDR(source));
  atom_t limits = CAR(CDR(CDR(source))); 
  atom_t commands_lisp = CAR(CDR(CDR(CDR(source))));
  
  int branch = 0;
  int branch2 = -1;

  branch = 0;

  if( !IS_LIST(limits) || !GET_FLAGS(limits,FLAG_WAS_LIST_CONST) )
  {
      return new_error(ERROR_NOT_A_LIST_CONST,limits);
  }

  if( !IS_LIST(commands_lisp) || !GET_FLAGS(commands_lisp,FLAG_WAS_LIST_CONST) )
  {
      return new_error(ERROR_NOT_A_LIST_CONST,commands_lisp);
  }
  
  if( IS_EMPTY(limits) || IS_EMPTY(CDR(limits)) )
  {
      return new_error(ERROR_MISSING_FOR_LIMITS,source);
  }
  
  // compile initial limit
  atom_t y = compile_expr( ctx, limits, COMPILE_AS_FUNC );
  if( IS_ERROR(y) ) return y;

  // copy this limit to the control variable
  if( !IS_ANY_WORD(name)
      || LENGTH(name)<2
      || *STRING(name)!=TEXT('"') )
      return new_error( ERROR_NOT_A_WORD_CONST, name );
  
  if( !ctx->generate )
  {
      atom_t inc;

      atom_t qname = new_word( STRING(name), LENGTH(name) );
      *STRING(qname) = L':';
      
      atom_t cname = new_word( STRING(name), LENGTH(name)+1 );
      memmove( STRING(cname)+1, STRING(cname), LENGTH(name)*CHAR_SIZE );
      *STRING(cname) = L':';
      *(STRING(cname)+1) = L'^';
      
      inc = new_list(cname,empty_list);
      inc = new_list(qname,inc);
      inc = new_list(USE(word_plus),inc);
      SET_FLAGS(inc,FLAG_EXPRESSION);
      inc = new_list(inc,empty_list);
      inc = new_list(USE(name),inc);
      inc = new_list(USE(word_make),inc);
      SET_FLAGS(inc,FLAG_EXPRESSION+FLAG_WAS_LIST_CONST);

      if( IS_EMPTY(commands_lisp) )
      {
          //printf("~1~\n");
          commands_lisp = new_list(inc,empty_list);
          CAR(CDR(CDR(CDR(source)))) = commands_lisp;
          SET_FLAGS(commands_lisp,FLAG_EXPRESSION+FLAG_WAS_LIST_CONST);
      }
      else
      {
          //printf("~2~\n");
          atom_t x = commands_lisp;
          while( !IS_EMPTY(CDR(x)) ) x = CDR(x);
          CDR(x) = new_list(inc,empty_list);
      }
      //printf("===========NEW LISP==="); dumpln(commands_lisp);
  }
 
  atom_t real_name = new_subword( name, STRING(name)+1, LENGTH(name)-1 );
  //printf("real name="); dumpln(real_name);
  //printf("parent="); dumpln(ctx->parent);
  atom_t control_var = find_var( real_name, ctx->parent );
  assert( control_var );
  DEUSE( real_name );
  
  atom_t step_name = new_word( STRING(name), LENGTH(name) );
  *STRING(step_name) = L'^';
  atom_t step_var = find_var( step_name, ctx->parent );
  assert( step_var );
  DEUSE( step_name );

  // new value of control var is already in stack,
  // duplicate it in otder to make:   MAKE "<VAR> <FROM_VALUE>
  asm_pop_result( ctx );
  asm_push_result( ctx );
  asm_push_result( ctx );
  asm_make_direct( ctx, control_var, source );
  
  // compile final limit
  y = compile_expr( ctx, CDR(limits), COMPILE_AS_FUNC );
  if( IS_ERROR(y) ) return y;

  // compile step (if any)
  if( IS_NOT_EMPTY(CDR(CDR(limits))) )
  {
      y = compile_expr( ctx, CDR(CDR(limits)), COMPILE_AS_FUNC );
      if( IS_ERROR(y) ) return y;
  }
  else
  {
      asm_push_atom( ctx, unbound );
  }
  
  branch = asm_for_prologue( ctx, step_var, limits, &branch2 );

  y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
  if( IS_ERROR(y) ) return y;

  asm_for_epilogue( ctx, branch, branch2 );

  return unbound;
}
void init_compiler ( outter_t  outter,
inner_t  inner,
inner_eof_t  inner_eof 
)
Parameters:
outteroutter function to use by dump and dumpln
innerinner function to use for text input
inner_eofinner_eof function to test eof of text input

Initializes the compiler and all other modules 

{
  //2011.02.09 Now output to console is always through UTF-8 (see lhogho.c)
  //#ifdef UNICODE_CHARS
  //fwide(stdout,1);
  //#else
  //fwide(stdout,-1);
  //#endif

  running_compiled_code = 0;
  compiling_code = 0;

  init_output( outter );
  init_input( inner, inner_eof );
  init_atoms();
  init_parser();
  init_vars();
  init_runtime();
  init_options( );
  init_errors( );
  
  //printf("testing barrization\n");
  //char_t i;
  //printf("a->|a|\t|a|->a\n");
  //for(i=0;i<128;i++) if( (i!=ENBAR(i)) || (i!=DEBAR(i)) )
  //  {
  //    if(i!=ENBAR(i))
  //    printf("%d->%d",i,ENBAR(i));
  //    else printf("\t");
  //
  //    if(i!=DEBAR(i))
  //    printf("\t%d->%d",i,DEBAR(i));
  //    printf("\n");
  //  }
}
void finit_compiler ( )

Finalizes all modules of the compiler. 

{
  if( OPTION_VARIABLES || OPTION_USER_VARIABLES )
    {
      outter( TEXT("Variables:\n\0"), UNKNOWN );
      dumpln( root );
      //outter( TEXT("\n\0"), UNKNOWN );
    }
  clear_all_errors();
  finit_errors();
  finit_runtime();
  finit_vars();
  finit_atoms();
  finit_options();
}
int compile_from_options ( )
Returns:
0 if there was no error

Compiles according to the compiler's options. In case of error dumps the error message and returns non-zero value. 

{
   //printf("enter compile()\n");
   //printf("##### path=|%s|#######\n",getcwd (NULL,0));
   //printf("enter compile()\n");
   //printf("##### path=|%s|#######\n",getcwd (NULL,0));

  atom_t x;
  atom_t sources = empty_list;

  // load comman-line source
  if( option_source_filename_chars )
    {
      x = read_word( option_source_filename_chars );
      if( IS_ERROR(x) )
      {
        dumpln(x);
        return 1;
      }
      atom_t y = trim_shell_comment( x );
      DEUSE( x );
      sources = new_list( y, sources );
    }

  // load embedded sources
  int   ptr;
  unsigned char* code = load_file( option_compiler_filename_chars, &ptr );

  // check for magic number
  while( (*(int*)(code+ptr-4)==MAGIC_NUMBER) || (*(int*)(code+ptr-4)==MAGIC_COMPILER_NUMBER))
    {
      int size = *(int*)(code+ptr-8);
      ptr -= size+8;
      x = decode_word(code+ptr,size,0);
      atom_t y = trim_shell_comment( x );
      DEUSE( x );
      sources = new_list( y, sources );
    }
 
  DEALLOC( code );

  // if there is any source then read it and compile it
  if( IS_EMPTY(sources) )
    {
      output_compiler_name( 0 );
      return 0;
    }

  compiling_code = 1;
  FULLSOURCE(root) = ( sources ); // already used once
  SOURCE(root) = USE( sources );
  x = compile_function( root, COMPILE_AS_PROC, COMPILE_AS_NON_MACRO );
  if( IS_ERROR(x) )
    {
      dumpln(x);
      //DEUSE(x);
      clear_all_errors();
      compiling_code=0; 
      return 1; 
    }
  compiling_code = 0;


  // now the sources is confirmed to be compilable
  // now check whether an executable file must be created
  if( OPTION_MAKE_EXECUTABLE || OPTION_MAKE_EXECUTABLE_COMPILER )
    {
      x = compile_to_file( );
      if( IS_ERROR(x) ) { dumpln(x); DEUSE(x); return 1; }
    }
  return 0;
}
atom_t compile_to_file ( )

Compiles current source into executable file. The name of the file is based on the name of the external source. EXE extension is used for Windows systems. For Linux no extension is used. The generated file has read-write-execute user permisions.

If the option_make_executable_compiler is set, then the compiled file acts like a compiler in respect to its inputs.

If the option_make_executable is set, then the compiled file acts as a standalone file and does not use any of the Lhogho options. 

{
  FILE* infile;
  FILE* outfile;

  // compose the output name
  char* output_filename;
  chars_t output_filename_chars;
  
  {
    // [1] use the original source name
    // [2] remove trailing extension (as defined in source_extensions)
    //     if extension is different, do not remove anything
    // [3] append the executable extension (as defined in EXE_EXT)
    output_filename = (char*)alloca( strlen(option_source_filename)+strlen(EXE_EXT)+100 );
    strcpy( output_filename, option_source_filename );

    char* extension = output_filename+strlen(output_filename);

    // remove any source extension
    int i;
    int done = 0;
    for( i=0; i<SRC_EXT_COUNT; i++)
    {
      if( strcasecmp(extension-strlen(SRC_EXT),SRC_EXT)==0 )
      {
        strcpy( extension-strlen(SRC_EXT), EXE_EXT );
        done = 1;
        break;
      }
    }
    
    // add executable extension if not done already
    if( !done )
    {
      #ifdef SAFEMODE
        assert( strlen(EXE_EXT2)!=0 );
      #endif
      
      if( strlen(EXE_EXT)==0 )
        strcpy( extension, EXE_EXT2 );
      else
        strcpy( extension, EXE_EXT );
    }
    
    output_filename_chars = UNFILENAME( output_filename );

    outfile = fopen( output_filename, "wb" );
    if( errno ) return new_os_error( output_filename_chars );
  }

  #define BUF_SIZE 1024
  char* buffer[BUF_SIZE];
  int size;

  // copy compiler into output file
  infile = fopen( option_compiler_filename, "rb" );
  if( errno ) return new_os_error( option_compiler_filename_chars );

  while( (size = fread( buffer, 1, BUF_SIZE, infile )) )
    {
      if( errno ) return new_os_error( option_compiler_filename_chars );

      fwrite( buffer, 1, size, outfile );
      if( errno ) return new_os_error( output_filename_chars );
    }
  fclose( infile );
  if( errno ) return new_os_error( option_compiler_filename_chars );

  // copy source into output file
  int source_size = 0;
  infile = fopen( option_source_filename, "rb" );
  if( errno ) return new_os_error( option_source_filename_chars );

  while( (size = fread( buffer, 1, BUF_SIZE, infile )) )
    {
      if( errno ) return new_os_error( option_source_filename_chars );

      source_size += size;
      fwrite( buffer, 1, size, outfile );
      if( errno ) return new_os_error( output_filename_chars );
    }
  fclose( infile );
  if( errno ) return new_os_error( option_source_filename_chars );

  // write source size
  fwrite( &source_size, 1, 4, outfile );
  if( errno ) return new_os_error( output_filename_chars );

  // write magic data
  size = OPTION_MAKE_EXECUTABLE?MAGIC_NUMBER:MAGIC_COMPILER_NUMBER;
  fwrite( &size, 1, 4, outfile );
  if( errno ) return new_os_error( output_filename_chars );

  fclose( outfile );
  if( errno ) return new_os_error( output_filename_chars );

  chmod( output_filename, S_IRWXU );
  if( errno ) return new_os_error( output_filename_chars );

  return empty_list;
}
atom_t instruction_list ( atom_t  data)
Returns:
an instruction list

Ensures that CAR(data) is an instruction list. If it is is a list, then do nothing and return it. Otherwise replace it with [(RUN CAR(data))] 

{
  if( IS_EMPTY(data) ) return data;
  if( IS_EMPTY(CAR(data)) ) return data;

  //printf("ensure "); dump_atom(data,1); printf("\n");
  return data;
}
int run_function ( atom_t  function)
Returns:
exit code (0 if no error)

Runs the compiled code of a function. Assumes the function is already compiled without error. If error occurs during execution the error is dumped on the output stream and its code is returned. 

{
  #ifdef SAFE_MODE
    assert( ADDRESS(function) );
  #endif

  typedef atom_t(*user_code_t)(); // Lhogho-compiled user code

  user_code_t func = (user_code_t)ADDRESS(function);

  //int x;
  //printf("bin adr=%x\n",(int)func);
  //for( x=0; x<128; x++ )
  //  {
  //    if( x % 16 ) printf(","); else printf("\n\tdb\t");
  //    printf("$%x", *(((unsigned char*)func)+x));
  //  }
  //printf("\n");
  //printf("start executing\n");

  //printf("******BEFORE******\n");
  //dump_statistics();

  running_compiled_code = 1;
  atom_t result = func();
  running_compiled_code = 0;

  //printf("******AFTER******\n");
  //dump_statistics();

  //printf("result=%x\n",(int)result);
  //printf("ref=%d\n",REF(result));
  //printf("result(ref=%d)=",REF(result)); dumpln(result);

  //printf("before error rootdef="); dump_atom(DEFINITIONS(root),1); printf("\n");
  //printf("before error rootdef="); dump_atom(TREE(root),1); printf("\n");
  if( IS_ERROR(result) )
    {
      int exit_code = 0;
      if( ERRCODE(result)!= EXIT_BY_BYE && 
     ERRCODE(result)!= EXIT_BY_THROW_TOPLEVEL &&
     ERRCODE(result)!= EXIT_BY_THROW_SYSTEM )
   {
     dumpln( result );
     exit_code = ERRCODE(result);
   }
      DEUSE(last_error);
      last_error = empty_list;
      clear_all_errors();
      return exit_code;
    }
  else
    {
      DEUSE( result );
      return 0;
    }
}
int run_source ( chars_t  source)
Returns:
0 or exit_code

Compiles source code as if it is the main program. No variables are cleared before or after the compilation. Then runs the compiled code. 

{
  int exit_code;

  compiling_code = 1;
  atom_t x = new_word( source, -1 );
  atom_t y = trim_shell_comment( x );

  DEUSE( x );
  DEUSE( BODY(root) );   BODY(root) = empty_list;
  DEUSE( TREE(root) );   TREE(root) = empty_list;
  DEUSE( BINARY(root) ); BINARY(root) = empty_list;
  DEUSE( SOURCE(root) ); SOURCE(root) = empty_list;
  DEUSE( FULLSOURCE(root) ); FULLSOURCE(root) = empty_list;

  FULLSOURCE(root) = ( y ); // already used once
  SOURCE(root) = USE( y );
  x = compile_function( root, COMPILE_AS_PROC, COMPILE_AS_NON_MACRO );
  if( IS_ERROR(x) )
    {
      exit_code = ERRCODE(x);
      DEUSE( x );
      compiling_code = 0;
    }
  else
    {
      compiling_code = 0;
      exit_code = run_function(root);
      //exit_code = 0;
    }

  return exit_code;
}
atom_t compile_function ( atom_t  func,
int  mode,
int  is_macro 
)
Parameters:
funcfunction to compile
modecompilation mode (COMPILE_AS_ macros)
is_macromacro mode
Returns:
empty list or error atom

Compiles the body of a function. If the function is not parsed or a syntax tree is not generated then parse and treeify it first.

If is_macro is false, then the epilogue of the function releases all local variables - created at compile or at runtime.

If is_macro is true, then the epilogue of the function calls a function to process the locals. This function would typically save the locals in the parent variable. 

{
  #ifdef DEBUG_COMPILE
  printf("<COMPILE> Compile "); dump(NAME(func));
  if( mode==COMPILE_AS_PROC ) printf(" as procedure\n");
  if( mode==COMPILE_AS_FUNC ) printf(" as function\n");
  if( mode==COMPILE_AS_UNKNOWN ) printf(" as unknown\n");
  #endif

  need_descr2( func );

  atom_t x;
  atom_t y;
  // if there is not syntax tree of the function
  // then parse and treeify it first
  if( IS_EMPTY(TREE(func)) )
    {
     y = build_syntax_tree( func );
      if( IS_ERROR(y) ) return y;
    }

  #ifdef DEBUG_COMPILE
    printf("<COMPILE> Syntax tree built\n");
  #endif

  context_t ctx;
  ctx.size = 0;
  ctx.generate = NULL;
  ctx.parent = func;
  ctx.exit_addr = 0;
  //printf("SET0 ExAd=%d\n",ctx.exit_addr);

  // set offset of local variables
  int offset = BASE_OFFSET_LOCALS-4; // this is the start offset
  for( x = LOCALS(func); IS_NOT_EMPTY(x); x=CDR(x) )
    if( IS_VARIABLE(CAR(x)) && OFFSET(CAR(x))==0 && IS_NORMAL(CAR(x)) )
      {
   //printf("set offset of "); dump(NAME(CAR(x)));
   //printf(" to be %d\n",offset);
   OFFSET(CAR(x)) = offset;
   offset -= sizeof( atom_t );
      }

  #ifdef DEBUG_COMPILE
    printf("<COMPILE> Pass 1\n");
  #endif

  //------------------------------
  // calculate size of to-be-generated code
  asm_prologue( &ctx, func );

  if( IS_EMPTY(TREE(func)) )
    asm_empty_body( &ctx );
  else
    {
      SET_FLAGS( TREE(func), FLAG_WAS_LIST_CONST );
      y = compile_block( &ctx, TREE(func), mode );
      if( mode==COMPILE_AS_FUNC )
   {
     asm_output( &ctx, TREE(func), 0 ); // simulate OUTPUT
   }
      if( IS_ERROR(y) ) return y;
    }
  asm_preepilogue( &ctx );
  ctx.exit_addr = ctx.size;
  asm_epilogue( &ctx, func, is_macro );

  #ifdef DEBUG_COMPILE
    printf("<COMPILE> Pass 1 done!\n");
    printf("<COMPILE> Code size=%d\n\n",ctx.size);
    printf("<COMPILE> Pass 2\n");
  #endif

  //-----------------------------
  // allocate memory for code
  ctx.generate = new_mem( ctx.size );
  ctx.size = 0;
  //printf("old exit addr=%8x\n",ctx.exit_addr);
  ctx.exit_addr = (int)MEMORY(ctx.generate)+ctx.exit_addr;
  //printf("new base addr=%8x\n",(int)MEMORY(ctx.generate));
  //printf("new exit addr=%8x\n",ctx.exit_addr);


  //---------------------------------
  // generate code for the body of the function
  asm_prologue( &ctx, func );
  if( IS_EMPTY(TREE(func)) )
    asm_empty_body( &ctx );
  else
    {
      y = compile_block( &ctx, TREE(func), mode );
      if( mode==COMPILE_AS_FUNC ) asm_output( &ctx, TREE(func), 0 ); // simulate OUTPUT
      if( IS_ERROR(y) )
   {
     DEUSE( ctx.generate );
     return y;
   }
    }

  asm_preepilogue( &ctx );
  asm_epilogue( &ctx, func, is_macro );

  #ifdef DEBUG_COMPILE
    printf("<COMPILE> Pass 2 done!\n");
  #endif


  BINARY(func) = ctx.generate;
  ADDRESS(func) = (int)MEMORY(BINARY(func));

  //dumpln( root );

  // generate code for local functions
  for( x = LOCALS(func); IS_NOT_EMPTY(x); x=CDR(x) )
    if( !IS_VARIABLE(CAR(x)) && 
   !IS_PRIMITIVE(CAR(x)) && 
   !IS_TAG(CAR(x)) )
    {
      y = compile_function( CAR(x), COMPILE_AS_PROC, COMPILE_AS_NON_MACRO );
      if( IS_ERROR(y) ) return y;
    }

  return empty_list;
}
atom_t compile_external_function ( atom_t  func)
Parameters:
funcfunction to compile
Returns:
empty list or error atom

Compiles the trampoline of an external function. 

{
  #ifdef DEBUG_COMPILE
  printf("<COMPILE> Re-compile external "); dump(NAME(func));
  #endif

#ifdef SAFE_MODE
  assert( IS_EXTERNAL(func) );
#endif

  context_t ctx;
  ctx.size = 0;
  ctx.generate = NULL;
  ctx.parent = func;
  ctx.exit_addr = 0;

  #ifdef DEBUG_COMPILE
    printf("<COMPILE> Pass 1\n");
  #endif

  //------------------------------
  // calculate size of to-be-generated code
  asm_external_function( &ctx, func );

  //ctx.exit_addr = ctx.size;

  #ifdef DEBUG_COMPILE
    printf("<COMPILE> Pass 1 done!\n");
    printf("<COMPILE> Code size=%d\n\n",ctx.size);
    printf("<COMPILE> Pass 2\n");
  #endif

  //-----------------------------
  // allocate memory for code
  ctx.generate = new_mem( ctx.size );
  ctx.size = 0;


  //---------------------------------
  // generate code for the body of the function
  asm_external_function( &ctx, func );
  
  #ifdef DEBUG_COMPILE
    printf("<COMPILE> Pass 2 done!\n");
  #endif


  DEUSE(BINARY(func));
  BINARY(func) = ctx.generate;
  ADDRESS(func) = (int)MEMORY(BINARY(func));

  return empty_list;
}
atom_t compile_internal_function ( atom_t  func,
int  static_link 
)
Parameters:
funcfunction to compile
static_linkstatic link from the current frame
Returns:
empty list or error atom

Compiles the trampoline of an internal function. 

{
  #ifdef DEBUG_COMPILE
  printf("<COMPILE> Re-compile internal "); dump(NAME(func));
  #endif

#ifdef SAFE_MODE
  assert( IS_INTERNAL(func) );
#endif

  context_t ctx;
  ctx.size = 0;
  ctx.generate = NULL;
  ctx.parent = func;
  ctx.exit_addr = 0;

  #ifdef DEBUG_COMPILE
    printf("<COMPILE> Pass 1\n");
  #endif

  //------------------------------
  // calculate size of to-be-generated code
  asm_internal_function( &ctx, static_link, func );

  //ctx.exit_addr = ctx.size;

  #ifdef DEBUG_COMPILE
    printf("<COMPILE> Pass 1 done!\n");
    printf("<COMPILE> Code size=%d\n\n",ctx.size);
    printf("<COMPILE> Pass 2\n");
  #endif

  //-----------------------------
  // allocate memory for code
  ctx.generate = new_mem( ctx.size );
  ctx.size = 0;


  //---------------------------------
  // generate code for the body of the function
  asm_internal_function( &ctx, static_link, func );
  #ifdef DEBUG_COMPILE
    printf("<COMPILE> Pass 2 done!\n");
  #endif


  // The address of the function should point to the
  // newly created trampoline. The memory link should
  // contain atoms that must be freed when the function
  // is freed, namely:
  //    - the original memory atom
  //    - the new memory atom
  // The old memoty atom is needed, because it points
  // to the old code of the Lhogho function which is
  // actually used by the new code.
  BINARY(func) = new_list(ctx.generate,new_list(BINARY(func),empty_list));
  ADDRESS(func) = (int)MEMORY(ctx.generate);

  return empty_list;
}
int is_constant ( atom_t  lisp)
Parameters:
lispstatement to check
Returns:
1 if it is a constant; 0 - otherwise

Lisps which are expressions (i.e. they are in parentheses) are not constants. References to variables like ':a' are not constants. Everything else is considered constants. 

{
  //printf("is_constant "); dump_atom(lisp,1); printf("\n");

  // empty list
  if( IS_EMPTY(lisp) ) return 1;

  // number?
  if( IS_INTEGER(lisp) ) return 1;
  if( IS_FLOAT(lisp) ) return 1;

  // most non-expressions are constants
  if( !IS_LIST(lisp) || !IS_EXPRESSION(lisp) )
    {
      if( IS_ANY_WORD(lisp)
        && LENGTH(lisp)>1
        && *STRING(lisp)==TEXT(':') )
        {
          return 0;
        }
      return 1;
    }

  // if there are more than 1 items then it is not a constant
  if( IS_NOT_EMPTY(CDR(lisp)) ) return 0;

  // so we have one element - it could be:
  //  constant - (2)
  //  non-constant - (pi)
  atom_t elem = CAR(lisp);
  
  // (2)
  if( IS_INTEGER(elem) ) return 1; 

  // (2.5)
  if( IS_FLOAT(elem) ) return 1; 

  // ([2 5])
  if( IS_LIST(elem) && !IS_EXPRESSION(elem) ) return 1; 

  // (<not-word>), e.g. error, memory, var, ...
  if( !IS_ANY_WORD(elem) ) return 0;

  // ("a)
  if( LENGTH(elem)>1 && *STRING(elem)==TEXT('"') ) return 1;

  // (:a)
  if( LENGTH(elem)>1 && *STRING(elem)==TEXT(':') ) return 0;

  // (number)
  float64_t x;
  if( atom_to_float( elem, &x ) ) return 1;

  // not a constant
  return 0;
}
int is_reference ( atom_t  lisp)
Parameters:
lispstatement to check
Returns:
1 if it is a reference; 0 - otherwise

References are words which start with colon, like ':a'. 

{
  //printf("is reference="); dumpln(lisp);
  // if a word starting with ":" then is a reference
  if( IS_ANY_WORD(lisp)
      && LENGTH(lisp)>1
      && *STRING(lisp)==TEXT(':') )
    {
      //printf("it is reference\n");
      return 1;
    }

  // the only other reference is (:a)

  // non-expressions are not references
  if( !IS_EXPRESSION(lisp) ) return 0;

  // empty lists are not references
  if( IS_EMPTY(lisp) ) return 0;

  // if there are more than 1 items then it is not a reference
  if( IS_NOT_EMPTY(CDR(lisp)) ) return 0;

  //printf("call recursive\n");
  return is_reference( CAR(lisp) );
}
atom_t compile_lisp_const ( context_t *  ctx,
atom_t  lisp 
)
Parameters:
ctxcompilation context
lispconstant to compile
Returns:
unbound atom

Compiles a single constant. 

{
  atom_t value = IS_LIST(lisp)&&IS_EXPRESSION(lisp)?CAR(lisp):lisp;
  if( ctx->generate )
    { // create ABC from "ABC if the constant is a word constant
    
      //printf("before = "); dumpln(lisp);
      if( IS_LIST(lisp) && IS_EXPRESSION(lisp) ) lisp = CAR( lisp ); //Fix for bug #3427526
      //printf("after  = "); dumpln(lisp);
      
      if( IS_ANY_WORD( lisp )
        && LENGTH(lisp)>0
        && *STRING(lisp)==TEXT('"') )
      {
        value = new_subword( lisp, STRING(lisp)+1, LENGTH(lisp)-1 );
        ATOMS(ctx->generate) = new_list( value, ATOMS(ctx->generate) );
      }
    }
  asm_push_atom( ctx, value );
  return unbound;
}
atom_t compile_local ( context_t *  ctx,
atom_t  source,
int *  processed 
)
Parameters:
ctxcompilation context
sourceLOCAL's source
processed1 if the statement is processed
Returns:
unbound or error atom

Compiles a LOCAL statement. Actually does not compile but process the LOCAL's source by removing all constant-words. Such parameters should already be processed by the treefier. If all parameters are removed, then the whole LOCAL statement is ignored. Otherwise the modified source is processed as ordinary user-defined function. 

{
  // remove all inputs which are constant words
  // because they are processed automatically
  atom_t a;
  atom_t b;
  for( a=source; IS_NOT_EMPTY(CDR(a)); ) // possibly infinite if atoms are  broken
    {
      atom_t node = CAR(CDR(a));
      if( (!IS_ANY_WORD(node)) ||
          (LENGTH(node)==0) ||
          (*STRING(node)!=TEXT('"')) )
   {
     a = CDR(a);
     continue;
   }
      // get rid of the next element in the
      // list, because it is constant-word
      b = CDR(a);
      CDR(a) = CDR(b);
      CDR(b) = empty_list;
      DEUSE( b );
    }
  // check whether everything is removed
  // if yes, then no need to process LOCAL any more
  *processed = IS_EMPTY( CDR(source) );
  return unbound;
}
atom_t compile_make ( context_t *  ctx,
atom_t  source,
int  is_name,
int *  processed 
)
Parameters:
ctxcompilation context
sourceMAKE's source
is_nameMAKE=0, NAME=1
processed1 if the statement is processed
Returns:
unbound or error atom

Compiles a MAKE statement. The generated code depends on the parameters - whether they are constants or expressions. At the end of execution of generated code the result of MAKE should be in the stack (the result is either error atom or unbound atom).

Some MAKE statements cannot be processed - e.g. those in which the name of the variable is an expression. In such cases processed is set to 0. 

{
  atom_t params = CDR(source);
  atom_t name;
  atom_t value_src;
  if( is_name )
    {
      name = CAR(CDR(params));
      value_src = params;
    }
  else
    {
      name = CAR(params);
      value_src = CDR(params);
    }

  //printf("value="); dumpln(value_src);
  *processed = 1;

  // Check the first input of MAKE. If it is a word constant
  // then we have immediate MAKE which is compiled directly.
  // Otherwise we have indirect MAKE.

  if( IS_ANY_WORD(name)
      && LENGTH(name)>1
      && *STRING(name)==TEXT('"') )
    {
      // We have direct MAKE - i.e. we know the name of the
      // variable which value is changed. Generate code which
      // will push the absolute address of the variable.
      atom_t real_name = new_subword( name, STRING(name)+1, LENGTH(name)-1 );
      atom_t var = find_var( real_name, ctx->parent );
      if( var )
   {
     //printf("found var "); dump_atom(NAME(var),1); printf(" parent="); dumpln(NAME(PARENT(var)));
     //printf("--- isglobal=%d isnormal=%d isruntime=%d\n",IS_GLOBAL(var),IS_NORMAL(var),IS_RUNTIME(var));
     if( !IS_VARIABLE( var ) )
       {
         DEUSE( real_name );
         return new_error( ERROR_NOT_A_VAR, name );
       }
     // direct make + existing variable
     // push <value>
          atom_t y = compile_expr( ctx, value_src, COMPILE_AS_FUNC );
          if( IS_ERROR(y) ) return y;
     asm_make_direct( ctx, var, source );
   }
      else
   {
     // direct make + NON-existing variable
     *processed = 0;
   }
      DEUSE( real_name );
    }
  else
    {
      // indirect make
      // leave handling for rt_make
      //printf("not found var\n");
      *processed = 0;
    }

  return unbound;
}
atom_t compile_output ( context_t *  ctx,
atom_t  source 
)
Parameters:
ctxcompilation context
sourceOUTPUT's source
Returns:
unbound or error atom

Compiles an OUTPUT statement. 

{
  atom_t params = CDR(source);
  atom_t value_src = params;

  atom_t result = compile_expr( ctx, value_src, COMPILE_AS_FUNC );
  asm_output( ctx, source, 1 ); // true output

  return result;
}
atom_t compile_maybeoutput ( context_t *  ctx,
atom_t  source 
)
Parameters:
ctxcompilation context
sourceMAYBEOUTPUT's source
Returns:
unbound or error atom

Compiles an MAYBEOUTPUT statement. 

{
  atom_t params = CDR(source);
  atom_t value_src = params;

  atom_t result = compile_expr( ctx, value_src, COMPILE_AS_UNKNOWN );
  asm_push_result( ctx );
  asm_output( ctx, source, 1 ); // true output

  return result;
}
atom_t compile_stop ( context_t *  ctx,
atom_t  source 
)
Parameters:
ctxcompilation context
sourceSTOP's source
Returns:
unbound atom

Compiles a STOP statement. 

{
  asm_stop( ctx, source );
  return unbound;
}
atom_t compile_test ( context_t *  ctx,
atom_t  source,
int  criteria 
)
Parameters:
ctxcompilation context
sourceIFTRUE's or IFFALSE's source
criteriaIFTRUE=1, IFFALSE=0
Returns:
unbound or error atom

Compiles a iftrue or a iffalse statement. If the value of criteria is 1, then generated code is for iftrue. If it is 0, then the code is for iffalse. 

{
  atom_t commands = CAR(CDR(source));

  //printf("condition = "); dumpln(condition_lisp);
  //printf("commands  = "); dumpln(commands_lisp);

  int skip_branch = asm_test_prologue( ctx, criteria );

  atom_t y = compile_block( ctx, commands, COMPILE_AS_PROC );
  if( IS_ERROR(y) ) return y;

  asm_fix( ctx, skip_branch );

  return unbound;
}
atom_t compile_lisp_reference ( context_t *  ctx,
atom_t  source 
)
Parameters:
ctxcompilation context
sourcereference source
Returns:
unbound or error atom

Compiles a reference to variable's value - :a. 

{
  atom_t result = unbound;

  //printf("in===="); dumpln(source);
  atom_t name;
  if( IS_ANY_WORD(source) )
    name = source;
  else
    name = CAR(source);
  atom_t real_name = new_subword( name, STRING(name)+1, LENGTH(name)-1 );
  atom_t var = find_var( real_name, ctx->parent );
  if( var && IS_NORMAL(var) )
    {
      if( IS_VARIABLE( var ) )
   {
     // existing variable
     asm_reference( ctx, var, source, 1 );
   }
      else
   result = new_error( ERROR_NOT_A_VAR, name );
    }
  else
    {
      // NON-existing variable
      compile_lisp_const( ctx, name );
      asm_runtime_reference( ctx );
      asm_pop_atom( ctx );
      asm_push_result( ctx );
    }
  DEUSE( real_name );

  return result;
}

Variable Documentation

int running_compiled_code
int compiling_code
char* source_extensions[] = { ".lgo", ".log", ".lg", ".logo", ".lho", ".lhogho" }
[ HOME | INDEX | ATOMS | VARS | REFERENCE ]
Lhogho Developer's Documentation
Tue Feb 7 2012