Lhogho  0.0.028
 All Data Structures Files Functions Variables Typedefs Macros Pages
compiler.c File Reference

Go to the source code of this file.

Macros

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

Variables

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

Macro Definition Documentation

#define SRC_EXT_COUNT   (sizeof source_extensions)/(sizeof source_extensions[0])

Definition at line 142 of file compiler.c.

#define SRC_EXT   (source_extensions[i])

Definition at line 143 of file compiler.c.

#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.

Definition at line 1829 of file compiler.c.

1830 {
1831 #define RETURN_NO_CHECK(INSTR) \
1832  { \
1833  result = INSTR; \
1834  needs_check = 0; \
1835  goto finalize; \
1836  }
1837 #define RETURN_NO_CHECK_EL(INSTR) \
1838  { \
1839  result = INSTR; \
1840  if( !IS_ERROR(result) ) result = empty_list;\
1841  needs_check = 0; \
1842  goto finalize; \
1843  }
1844 #define RETURN_CHECK(INSTR) \
1845  { \
1846  result = INSTR; \
1847  needs_check = 1; \
1848  goto finalize; \
1849  }
1850 
1851  atom_t orig_lisp = lisp;
1852  lisp = CAR(lisp);
1853 
1854  int needs_check = 1;
1855  atom_t result = unbound;
1856 
1857  #ifdef DEBUG_COMPILE
1858  printf("<COMPILE> Compile expression: "); dumpln(lisp);
1859  #endif
1860 
1861  // remove extra parentheses
1862  if( IS_LIST(lisp) )
1863  if( !IS_EMPTY(lisp) )
1864  if( IS_EXPRESSION(lisp) )
1865  while( IS_LIST(CAR(lisp)) && IS_EXPRESSION(CAR(lisp)) && IS_EMPTY(CDR(lisp)) )
1866  lisp = CAR(lisp);
1867 
1868  #ifdef DEBUG_COMPILE
1869  printf("<COMPILE> Normalized expression: "); dumpln(lisp);
1870  if( IS_LIST(lisp) && IS_EXTENDED(lisp) )
1871  {
1872  printf("<COMPILE>It's source is: |");
1873  dump(POS(lisp));
1874  printf("|\n");
1875  }
1876  #endif
1877 
1878  // if the source is a constant, then just push it
1879  if( is_constant(lisp) )
1880  {
1881  if( mode==COMPILE_AS_PROC )
1882  {
1883  if( IS_EXTENDED(lisp) && !IS_UNBOUND(POS(lisp)) )
1884  return new_error( ERROR_UNUSED_VALUE, POS(lisp) );
1885  else
1886  if( IS_EXTENDED(orig_lisp) && !IS_UNBOUND(POS(orig_lisp)) )
1887  return new_error( ERROR_UNUSED_VALUE, POS(orig_lisp) );
1888  else
1889  return new_error( ERROR_UNUSED_VALUE, lisp );
1890  }
1892  }
1893 
1894  // test whether the source is a reference
1895  if( is_reference( lisp ) )
1896  {
1897  if( mode==COMPILE_AS_PROC )
1898  return new_error( ERROR_UNUSED_VALUE, lisp );
1900  }
1901 
1902  // the source is not a constant and cannot be just pushed
1903  INFO( "" );
1904  INFO( "code for %a", lisp );
1905 
1906  // find the main function of the expression
1907  // it must be known variable
1908  atom_t varname = CAR( lisp );
1909  #ifdef SAFEMODE
1910  assert( IS_ANY_WORD(varname) );
1911  #endif
1912 
1913  if( LENGTH(varname)==1 && *STRING(varname)==TEXT('"') )
1914  {
1915  return new_error( ERROR_DO_NOT_KNOW, lisp );
1916  }
1917 
1918  atom_t var = find_var( varname, ctx->parent );
1919  #ifdef SAFEMODE
1920  assert( var );
1921  #endif
1922 
1923  // variables cannot be commands and procedures
1924  if( IS_VARIABLE(var) )
1925  return new_error( ERROR_NOT_A_FUNCTION, lisp );
1926 
1927  // commands do not return values
1928  if( (mode==COMPILE_AS_FUNC) && !IS_FUNCTION(var) )
1929  return new_error( ERROR_MISSING_VALUE, lisp );
1930 
1931  //printf("var="); dumpln(NAME(var));
1932 
1933  int addr = ADDRESS(var);
1934  #ifdef SAFEMODE
1935  if( IS_PRIMITIVE(var) ) assert( addr );
1936  #endif
1937 
1938  // dump source which is about to be executed or evaluated
1939  #ifdef ADVANCED
1940  if( OPTION_RUNTIME )
1941  {
1942  asm_dump_source( ctx, lisp );
1943  }
1944  #endif
1945 
1946 
1947  // SPECIAL COMPILATION CASES
1948  {
1949  // 0. _int3_
1950  if( addr==(int)rt_int3 )
1951  {
1952  asm_int_3( ctx );
1954  }
1955 
1956  // 1. local <name>
1957  if( addr==(int)rt_local )
1958  {
1959  int processed;
1960  result = compile_local( ctx, lisp, &processed );
1961  if( processed ) RETURN_NO_CHECK( result );
1962  }
1963 
1964  // 2. make <name> <value>
1965  if( addr==(int)rt_make )
1966  {
1967  int processed;
1968  result = compile_make( ctx, lisp, 0, &processed );
1969  //printf("processed make=%d\n",processed);
1970  if( processed ) RETURN_NO_CHECK( result );
1971  }
1972 
1973  // 3. name <value> <name>
1974  if( addr==(int)rt_name )
1975  {
1976  int processed;
1977  result = compile_make( ctx, lisp, 1, &processed );
1978  if( processed ) RETURN_NO_CHECK( result );
1979  }
1980 
1981  // 4a. output <value>
1982  if( addr==(int)rt_output )
1983  RETURN_NO_CHECK( compile_output(ctx,lisp) );
1984 
1985  // 4b. maybeoutput <value>
1986  if( addr==(int)rt_maybeoutput )
1987  RETURN_NO_CHECK( compile_maybeoutput(ctx,lisp) );
1988 
1989  // 5. stop
1990  if( addr==(int)rt_stop )
1991  RETURN_NO_CHECK( compile_stop(ctx,lisp) );
1992 
1993  // 6. if
1994  if( addr==(int)rt_if )
1995  RETURN_NO_CHECK( compile_if(ctx,lisp,mode) );
1996 
1997  // 7. repeat
1998  if( addr==(int)rt_repeat )
1999  RETURN_NO_CHECK( compile_repeat(ctx,lisp) );
2000 
2001  // 8. forever
2002  if( addr==(int)rt_forever )
2003  RETURN_NO_CHECK( compile_forever(ctx,lisp) );
2004 
2005  // 9. while
2006  if( addr==(int)rt_while )
2007  RETURN_NO_CHECK( compile_while(ctx,lisp,1,0) );
2008 
2009  // 10. until
2010  if( addr==(int)rt_until )
2011  RETURN_NO_CHECK( compile_while(ctx,lisp,0,0) );
2012 
2013  // 11. do.while
2014  if( addr==(int)rt_dowhile )
2015  RETURN_NO_CHECK( compile_while(ctx,lisp,1,1) );
2016 
2017  // 12. do.until
2018  if( addr==(int)rt_dountil )
2019  RETURN_NO_CHECK( compile_while(ctx,lisp,0,1) );
2020 
2021  // 13. catch
2022  if( addr==(int)rt_catch )
2023  RETURN_CHECK( compile_catch(ctx,lisp,mode) );
2024 
2025  // 14. tag
2026  if( addr==(int)rt_tag )
2027  RETURN_NO_CHECK( compile_tag(ctx,lisp) );
2028 
2029  // 15. goto
2030  if( addr==(int)rt_goto )
2031  RETURN_NO_CHECK( compile_goto(ctx,lisp,var) );
2032 
2033  // 16. iftrue
2034  if( addr==(int)rt_iftrue )
2035  RETURN_NO_CHECK( compile_test(ctx,lisp,1) );
2036 
2037  // 17. iffalse
2038  if( addr==(int)rt_iffalse )
2039  RETURN_NO_CHECK( compile_test(ctx,lisp,0) );
2040 
2041  // 18. for
2042  if( addr==(int)rt_for )
2043  RETURN_NO_CHECK( compile_for(ctx,lisp) );
2044 
2045  }
2046  // END OF SPECIAL COMPILATION CASES
2047 
2048 
2049  if( GET_FLAGS(var,FLAG_PUSH_MODE) )
2050  asm_push_mode( ctx, mode );
2051 
2052  if( GET_FLAGS(var,FLAG_PUSH_FRAME) )
2053  asm_push_frame( ctx );
2054 
2055  int params = 0;
2056  atom_t x;
2057  atom_t y;
2058  if( !IS_PRIMITIVE(var) && GET_FLAGS(var,FLAG_INFINITE_ARGS) )
2059  {
2060  //printf("<COMPILE> Compile func: "); dumpln(NAME(var));
2061  //printf("<COMPILE> LARGS=%d RARGS=%d\n",LARGS(var),RARGS(var));
2062 
2063  // skip number of compulsory params
2064  int skip;
2065  x = CDR(lisp);
2066  for( skip = LARGS(var)+RARGS(var); skip; skip-- )
2067  {
2068  if( IS_NOT_EMPTY(x) ) x = CDR(x);
2069  }
2070  // process all extra parameters
2071  for( ; IS_NOT_EMPTY(x); x=CDR(x) )
2072  {
2073  #ifdef DEBUG_COMPILE
2074  printf("<COMPILE> Compile parameter: "); dumpln(CAR(x));
2075  #endif
2076  y = compile_expr( ctx, x, COMPILE_AS_FUNC );
2077  if( IS_ERROR(y) ) return y;
2078  params++;
2079  }
2080  // process compulsory params
2081  x = CDR(lisp);
2082  for( skip = LARGS(var)+RARGS(var); skip; skip-- )
2083  {
2084  if( IS_NOT_EMPTY(x) )
2085  {
2086  #ifdef DEBUG_COMPILE
2087  printf("<COMPILE> Compile parameter: "); dumpln(CAR(x));
2088  #endif
2089  y = compile_expr( ctx, x, COMPILE_AS_FUNC );
2090  if( IS_ERROR(y) ) return y;
2091  x = CDR(x);
2092  }
2093  else
2094  {
2095  // Compile dummy parameter
2096  asm_push_atom( ctx, empty_list );
2097  }
2098  params++;
2099  }
2100  }
2101  else
2102  {
2103  for( x=CDR(lisp); IS_NOT_EMPTY(x); x=CDR(x) )
2104  {
2105  #ifdef DEBUG_COMPILE
2106  printf("<COMPILE> Compile parameter: "); dumpln(CAR(x));
2107  #endif
2108  y = compile_expr( ctx, x, COMPILE_AS_FUNC );
2109  if( IS_ERROR(y) ) return y;
2110  params++;
2111  }
2112  }
2113 
2114  asm_call_atom( ctx, var, params );
2115 
2116  int i;
2117  for( i=params-1; i>=0; i-- )
2118  {
2119  asm_pop_atom( ctx );
2120  }
2121 
2122  if( GET_FLAGS(var,FLAG_PUSH_FRAME) )
2123  asm_pop_frame( ctx );
2124 
2125  if( GET_FLAGS(var,FLAG_PUSH_MODE) )
2126  asm_pop_dummy( ctx );
2127 
2128  // special case for RUN, RUNMACRO and RUNRESULT - they return
2129  // a var atom containing the actual code to execute.
2130  if( addr==(int)rt_run ) { asm_run_epilogue( ctx ); }
2131  if( addr==(int)rt_runmacro ) { asm_run_epilogue( ctx ); }
2132  if( addr==(int)rt_runresult ) { asm_runresult_epilogue( ctx ); }
2133 
2134  asm_push_result( ctx );
2135  //disasm_atom( ctx, NAME(var) );
2136 
2137  finalize:
2138  if( needs_check )
2139  {
2140  if( mode==COMPILE_AS_FUNC ) asm_result_func( ctx, lisp );
2141  if( mode==COMPILE_AS_PROC ) asm_result_proc( ctx, lisp );
2142  if( mode==COMPILE_AS_UNKNOWN ) asm_result_unknown( ctx, lisp );
2143  }
2144  return result;
2145 }
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.

Definition at line 2163 of file compiler.c.

2164 {
2165  //printf("compile_block "); dumpln(lisp);
2166  //printf("mode=%d (func=%d cmd=%d unknown=%d)\n",mode,COMPILE_AS_FUNC,COMPILE_AS_PROC,COMPILE_AS_UNKNOWN);
2167 
2168  if( (mode==COMPILE_AS_FUNC) && IS_NOT_EMPTY(CDR(lisp)) )
2169  return new_error( ERROR_CROWDED_EXPRESSION, CDR(lisp) );
2170 
2171  if( mode==COMPILE_AS_UNKNOWN )
2172  if( IS_NOT_EMPTY(lisp) && IS_NOT_EMPTY(CDR(lisp)) )
2173  mode = COMPILE_AS_PROC;
2174 
2175  // there is a word
2176  if( IS_ANY_WORD(lisp) )
2177  {
2178  return new_error(ERROR_NOT_A_LIST_CONST,lisp);
2179  }
2180 
2181  // there is a lisp which is not produced by
2182  // a constant list
2183  if( !GET_FLAGS(lisp,FLAG_WAS_LIST_CONST) )
2184  {
2185  return new_error(ERROR_NOT_A_LIST_CONST,lisp);
2186  }
2187 
2188  atom_t x;
2189  for( x=lisp; IS_NOT_EMPTY(x); x=CDR(x) )
2190  {
2191  #ifdef DEBUG_COMPILE
2192  printf("<COMPILE> Compile command: "); dumpln(CAR(x));
2193  #endif
2194 
2195  atom_t y = compile_expr( ctx, x, mode );
2196  if( IS_ERROR(y) ) return y;
2197 
2198  // do not leave results in the stack
2199  if( IS_EMPTY(y) && mode==COMPILE_AS_UNKNOWN )
2200  asm_pop_result( ctx );
2201 
2202  #ifdef DEBUG_COMPILE
2203  printf("<COMPILE> Command compiled!\n");
2204  #endif
2205  }
2206 
2207  if( IS_EMPTY(lisp) )
2208  {
2209  if( mode==COMPILE_AS_FUNC )
2210  {
2211  asm_empty_body( ctx );
2212  asm_push_result( ctx );
2213  }
2214  }
2215  return unbound;
2216 }
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).

Definition at line 1235 of file compiler.c.

1236 {
1237  atom_t params = CDR(source);
1238  atom_t condition_src = params;
1239  atom_t condition = CAR(params);
1240  atom_t then_lisp = instruction_list(CAR(CDR(params)));
1241  atom_t else_lisp = instruction_list(CAR(CDR(CDR(params))));
1242 
1243  int has_else = !IS_EMPTY(else_lisp);
1244 
1245  if( mode==COMPILE_AS_FUNC && !has_else )
1246  return( new_error( ERROR_MISSING_RIGHTS, source ) );
1247 
1248  int branch = 0;
1249  int ifend = 0;
1250 
1251  //printf("IF STATEMENT\n");
1252  //printf(" COND="); dumpln(condition);
1253  //printf(" THEN="); dumpln(then_lisp);
1254  //printf(" ELSE="); dumpln(else_lisp);
1255 
1256  // compile condition of IF
1257  atom_t y = compile_expr( ctx, condition_src, COMPILE_AS_FUNC );
1258  if( IS_ERROR(y) ) return y;
1259 
1260  // add checker for boolean value
1261  asm_boolean( ctx, condition );
1262  branch = asm_if_prologue( ctx );
1263 
1264  // compile THEN of IF
1265  asm_label( ctx, TEXT("$then") );
1266  y = compile_block( ctx, then_lisp, mode );
1267  if( IS_ERROR(y) ) return y;
1268  if( has_else )
1269  ifend = asm_if_epilogue( ctx );
1270  asm_fix( ctx, branch );
1271 
1272  // compile ELSE of IF
1273  asm_label( ctx, TEXT("$else") );
1274  if( has_else )
1275  {
1276  y = compile_block( ctx, else_lisp, mode );
1277  if( IS_ERROR(y) ) return y;
1278  asm_fix( ctx, ifend );
1279  asm_label( ctx, TEXT("$ifend") );
1280  }
1281 
1282  if( mode==COMPILE_AS_PROC )
1283  asm_adjust_result( ctx );
1284 
1285  return unbound;
1286 }
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).

Definition at line 1359 of file compiler.c.

1360 {
1361  atom_t params = CDR(source);
1362  atom_t repcount_src = params;
1363  atom_t repcount = CAR(params);
1364  atom_t commands_lisp = CAR(CDR(params));
1365 
1366  int branch;
1367  int branch2 = -1;
1368 
1369  if( IS_LIST(repcount) )
1370  {
1371  try_expr:
1372  // REPEAT {expr} [...]
1373  branch = 0;
1374 
1375  atom_t y = compile_expr( ctx, repcount_src, COMPILE_AS_FUNC );
1376  if( IS_ERROR(y) ) return y;
1377 
1378  branch = asm_repeat_prologue_expr( ctx, repcount, &branch2 );
1379  }
1380  else
1381  {
1382  // REPEAT {const} [...]
1383  int64_t cnt;
1384  if( !atom_to_int( repcount, &cnt ) )
1385  goto try_expr;
1386  // return new_error_atom( ERROR_NOT_AN_INTEGER, repcount );
1387 
1388  if( cnt==0 )
1389  return unbound;
1390 
1391  if( cnt>INT_MAX )
1392  return new_error( ERROR_TOO_BIG_NUMBER, repcount );
1393 
1394  if( cnt<1 )
1395  return new_error( ERROR_TOO_SMALL_NUMBER, repcount );
1396 
1397  branch = asm_repeat_prologue_const( ctx, cnt );
1398  }
1399 
1400  atom_t y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
1401  if( IS_ERROR(y) ) return y;
1402 
1403  asm_repeat_epilogue( ctx, branch, branch2 );
1404 
1405  return unbound;
1406 }
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.

Definition at line 1580 of file compiler.c.

1581 {
1582  atom_t condition_src;
1583  //atom_t condition_lisp;
1584  atom_t commands_lisp;
1585  if( is_do )
1586  {
1587  condition_src = CDR(CDR(source));
1588  commands_lisp = CAR(CDR(source));
1589  }
1590  else
1591  {
1592  condition_src = CDR(source);
1593  commands_lisp = CAR(CDR(CDR(source)));
1594  }
1595  //condition_lisp = CAR(condition_src);
1596 
1597  //printf("condition = "); dumpln(condition_lisp);
1598  //printf("commands = "); dumpln(commands_lisp);
1599 
1600  int loop_branch = asm_while_prologue( ctx, is_while, is_do );
1601 
1602  if( is_do )
1603  {
1604  atom_t y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
1605  if( IS_ERROR(y) ) return y;
1606  }
1607 
1608  atom_t x = compile_expr( ctx, condition_src, COMPILE_AS_FUNC );
1609  if( IS_ERROR(x) ) return x;
1610 
1611  int skip_branch = asm_while_inlogue( ctx, commands_lisp, is_while );
1612 
1613  if( !is_do )
1614  {
1615  atom_t y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
1616  if( IS_ERROR(y) ) return y;
1617  }
1618 
1619  asm_while_epilogue( ctx, loop_branch, skip_branch, is_while );
1620 
1621  return unbound;
1622 }
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.

Definition at line 1419 of file compiler.c.

1420 {
1421  atom_t commands_lisp = CAR(CDR(source));
1422 
1423  int branch = asm_forever_prologue( ctx );
1424 
1425  atom_t y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
1426  if( IS_ERROR(y) ) return y;
1427 
1428  asm_forever_epilogue( ctx, branch );
1429 
1430  return unbound;
1431 }
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.

Definition at line 1304 of file compiler.c.

1305 {
1306  //printf("commands="); dumpln(source);
1307  atom_t params = CDR(source);
1308  atom_t tag_src = params;
1309  atom_t commands = CAR(CDR(params));
1310 
1311  // generate catch trampoline (prologue changes exit_addr)
1312  int old_exit_addr = ctx->exit_addr;
1313  int branch = asm_catch_prologue( ctx );
1314 
1315  // compile catch body
1316  atom_t y;
1317  y = compile_block( ctx, commands, mode );
1318  if( IS_ERROR(y) ) return y;
1319 
1320  // generate catch prologue and restore exit_addr
1321  ctx->exit_addr = old_exit_addr;
1322 
1323  // compile tag
1324  asm_label( ctx, TEXT("exit_catch:") );
1325  asm_fix( ctx, branch );
1326  //asm_int_3( ctx );
1327  if( mode==COMPILE_AS_PROC )
1328  asm_push_result( ctx );
1329  else
1330  asm_set_output_status( ctx, 0 );
1331  y = compile_expr( ctx, tag_src, COMPILE_AS_FUNC );
1332  if( IS_ERROR(y) ) return y;
1333  asm_catch_epilogue( ctx );
1334  //asm_exit_if_output( ctx );
1335  return empty_list;
1336 }
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.

Definition at line 1670 of file compiler.c.

1671 {
1672  atom_t tag = CAR(CDR(source));
1673 
1674  if( !IS_ANY_WORD(tag) )
1675  return new_error( ERROR_NOT_A_WORD, tag );
1676 
1677  tag = new_subword( tag, STRING(tag)+1, LENGTH(tag)-1 );
1678 
1679  // remember the current position in generated code
1680  // only suring the first pass
1681  if( !ctx->generate )
1682  {
1683  atom_t var = new_var( tag, ctx->parent, 1 );
1684  VARTYPE( var ) = VAR_TYPE_TAG;
1685  VALUE( var ) = new_integer( ctx->size );
1686  SET_FLAGS( var, FLAG_VARIABLE );
1687  }
1688  else
1689  {
1690  if( OPTION_ASSEMBLER ) asm_label( ctx, STRING(tag) );
1691  }
1692 
1693  DEUSE( tag );
1694  return unbound;
1695 }
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.

Definition at line 1715 of file compiler.c.

1716 {
1717  atom_t target_src = CDR(source);
1718  atom_t target = CAR(target_src);
1719 
1720  //printf("target="); dumpln(target);
1721 
1722  // try to find whether the target is known at compile-time
1723  if( IS_ANY_WORD(target)
1724  && LENGTH(target)>1
1725  && *STRING(target)==TEXT('"') )
1726  {
1727 
1728  // We have direct GOTO - i.e. we know the target's name
1729  atom_t real_name = new_subword( target, STRING(target)+1, LENGTH(target)-1 );
1730  atom_t var = find_local_var( real_name, ctx->parent );
1731  DEUSE( real_name );
1732 
1733  // test whether the target exists during
1734  // the second pass of the compilation
1735  if( ctx->generate && (!var || !IS_TAG(var)) )
1736  {
1737  return new_error( ERROR_NOT_A_TAG, target );
1738  }
1739  asm_goto( ctx, var );
1740  return unbound;
1741 
1742  }
1743 
1744  // the target is not a word-constant
1745 
1746  asm_goto_prologue( ctx, target ); // pushes target's source
1747 
1748  // prepare tag
1749  atom_t y = compile_expr( ctx, target_src, COMPILE_AS_FUNC );
1750  if( IS_ERROR(y) ) return y;
1751 
1752  asm_call_atom( ctx, var, 1 );
1753  asm_pop_atom( ctx ); // pop tag
1754  asm_pop_dummy ( ctx ); // pop source
1755  asm_goto_epilogue( ctx, target );
1756  return unbound;
1757 }
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.

Definition at line 1444 of file compiler.c.

1445 {
1446  atom_t name = CAR(CDR(source));
1447  atom_t limits = CAR(CDR(CDR(source)));
1448  atom_t commands_lisp = CAR(CDR(CDR(CDR(source))));
1449 
1450  int branch = 0;
1451  int branch2 = -1;
1452 
1453  branch = 0;
1454 
1455  if( !IS_LIST(limits) || !GET_FLAGS(limits,FLAG_WAS_LIST_CONST) )
1456  {
1457  return new_error(ERROR_NOT_A_LIST_CONST,limits);
1458  }
1459 
1460  if( !IS_LIST(commands_lisp) || !GET_FLAGS(commands_lisp,FLAG_WAS_LIST_CONST) )
1461  {
1462  return new_error(ERROR_NOT_A_LIST_CONST,commands_lisp);
1463  }
1464 
1465  if( IS_EMPTY(limits) || IS_EMPTY(CDR(limits)) )
1466  {
1467  return new_error(ERROR_MISSING_FOR_LIMITS,source);
1468  }
1469 
1470  // compile initial limit
1471  atom_t y = compile_expr( ctx, limits, COMPILE_AS_FUNC );
1472  if( IS_ERROR(y) ) return y;
1473 
1474  // copy this limit to the control variable
1475  if( !IS_ANY_WORD(name)
1476  || LENGTH(name)<2
1477  || *STRING(name)!=TEXT('"') )
1478  return new_error( ERROR_NOT_A_WORD_CONST, name );
1479 
1480  if( !ctx->generate )
1481  {
1482  atom_t inc;
1483 
1484  atom_t qname = new_word( STRING(name), LENGTH(name) );
1485  *STRING(qname) = L':';
1486 
1487  atom_t cname = new_word( STRING(name), LENGTH(name)+1 );
1488  memmove( STRING(cname)+1, STRING(cname), LENGTH(name)*CHAR_SIZE );
1489  *STRING(cname) = L':';
1490  *(STRING(cname)+1) = L'^';
1491 
1492  inc = new_list(cname,empty_list);
1493  inc = new_list(qname,inc);
1494  inc = new_list(USE(word_plus),inc);
1496  inc = new_list(inc,empty_list);
1497  inc = new_list(USE(name),inc);
1498  inc = new_list(USE(word_make),inc);
1500 
1501  if( IS_EMPTY(commands_lisp) )
1502  {
1503  //printf("~1~\n");
1504  commands_lisp = new_list(inc,empty_list);
1505  CAR(CDR(CDR(CDR(source)))) = commands_lisp;
1507  }
1508  else
1509  {
1510  //printf("~2~\n");
1511  atom_t x = commands_lisp;
1512  while( !IS_EMPTY(CDR(x)) ) x = CDR(x);
1513  CDR(x) = new_list(inc,empty_list);
1514  }
1515  //printf("===========NEW LISP==="); dumpln(commands_lisp);
1516  }
1517 
1518  atom_t real_name = new_subword( name, STRING(name)+1, LENGTH(name)-1 );
1519  //printf("real name="); dumpln(real_name);
1520  //printf("parent="); dumpln(ctx->parent);
1521  atom_t control_var = find_var( real_name, ctx->parent );
1522  assert( control_var );
1523  DEUSE( real_name );
1524 
1525  atom_t step_name = new_word( STRING(name), LENGTH(name) );
1526  *STRING(step_name) = L'^';
1527  atom_t step_var = find_var( step_name, ctx->parent );
1528  assert( step_var );
1529  DEUSE( step_name );
1530 
1531  // new value of control var is already in stack,
1532  // duplicate it in otder to make: MAKE "<VAR> <FROM_VALUE>
1533  asm_pop_result( ctx );
1534  asm_push_result( ctx );
1535  asm_push_result( ctx );
1536  asm_make_direct( ctx, control_var, source );
1537 
1538  // compile final limit
1539  y = compile_expr( ctx, CDR(limits), COMPILE_AS_FUNC );
1540  if( IS_ERROR(y) ) return y;
1541 
1542  // compile step (if any)
1543  if( IS_NOT_EMPTY(CDR(CDR(limits))) )
1544  {
1545  y = compile_expr( ctx, CDR(CDR(limits)), COMPILE_AS_FUNC );
1546  if( IS_ERROR(y) ) return y;
1547  }
1548  else
1549  {
1550  asm_push_atom( ctx, unbound );
1551  }
1552 
1553  branch = asm_for_prologue( ctx, step_var, limits, &branch2 );
1554 
1555  y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
1556  if( IS_ERROR(y) ) return y;
1557 
1558  asm_for_epilogue( ctx, branch, branch2 );
1559 
1560  return unbound;
1561 }
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

Definition at line 169 of file compiler.c.

170 {
171  //2011.02.09 Now output to console is always through UTF-8 (see lhogho.c)
172  //#ifdef UNICODE_CHARS
173  //fwide(stdout,1);
174  //#else
175  //fwide(stdout,-1);
176  //#endif
177 
179  compiling_code = 0;
180 
181  init_output( outter );
183  init_atoms();
184  init_parser();
185  init_vars();
186  init_runtime();
187  init_options( );
188  init_errors( );
189 
190  //printf("testing barrization\n");
191  //char_t i;
192  //printf("a->|a|\t|a|->a\n");
193  //for(i=0;i<128;i++) if( (i!=ENBAR(i)) || (i!=DEBAR(i)) )
194  // {
195  // if(i!=ENBAR(i))
196  // printf("%d->%d",i,ENBAR(i));
197  // else printf("\t");
198  //
199  // if(i!=DEBAR(i))
200  // printf("\t%d->%d",i,DEBAR(i));
201  // printf("\n");
202  // }
203 }
void finit_compiler ( )

Finalizes all modules of the compiler.

Definition at line 214 of file compiler.c.

215 {
217  {
218  outter( TEXT("Variables:\n\0"), UNKNOWN );
219  dumpln( root );
220  //outter( TEXT("\n\0"), UNKNOWN );
221  }
223  finit_errors();
224  finit_runtime();
225  finit_vars();
226  finit_options();
227  finit_atoms();
228 }
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.

Definition at line 242 of file compiler.c.

243 {
244  //printf("enter compile()\n");
245  //printf("##### path=|%s|#######\n",getcwd (NULL,0));
246  //printf("enter compile()\n");
247  //printf("##### path=|%s|#######\n",getcwd (NULL,0));
248 
249  atom_t x;
250  atom_t sources = empty_list;
251 
252  // load comman-line source
254  {
256  if( IS_ERROR(x) )
257  {
258  dumpln(x);
259  return 1;
260  }
261  atom_t y = trim_shell_comment( x );
262  DEUSE( x );
263  sources = new_list( y, sources );
264  }
265 
266  // load embedded sources
267  int ptr;
268  unsigned char* code = load_file( option_compiler_filename_chars, &ptr );
269  if( !code )
270  {
272  dumpln( error );
273  return 0;
274  }
275 
276  // check for magic number
277  while( (*(int*)(code+ptr-4)==MAGIC_NUMBER) || (*(int*)(code+ptr-4)==MAGIC_COMPILER_NUMBER))
278  {
279  int size = *(int*)(code+ptr-8);
280  ptr -= size+8;
281  x = decode_word(code+ptr,size,0);
282  atom_t y = trim_shell_comment( x );
283  DEUSE( x );
284  sources = new_list( y, sources );
285  }
286 
287  DEALLOC( code );
288 
289  // if there is any source then read it and compile it
290  if( IS_EMPTY(sources) )
291  {
293  return 0;
294  }
295 
296  compiling_code = 1;
297  FULLSOURCE(root) = ( sources ); // already used once
298  SOURCE(root) = USE( sources );
300  if( IS_ERROR(x) )
301  {
302  dumpln(x);
303  //DEUSE(x);
305  compiling_code=0;
306  return 1;
307  }
308  compiling_code = 0;
309 
310 
311  // now the sources is confirmed to be compilable
312  // now check whether an executable file must be created
314  {
315  x = compile_to_file( );
316  if( IS_ERROR(x) ) { dumpln(x); DEUSE(x); return 1; }
317  }
318  return 0;
319 }
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.

Definition at line 341 of file compiler.c.

342 {
343  FILE* infile;
344  FILE* outfile;
345 
346  // compose the output name
347  char* output_filename;
348  chars_t output_filename_chars;
349 
350  {
351  // [1] use the original source name
352  // [2] remove trailing extension (as defined in source_extensions)
353  // if extension is different, do not remove anything
354  // [3] append the executable extension (as defined in EXE_EXT)
355  output_filename = (char*)ALLOC( strlen(option_source_filename)+strlen(EXE_EXT)+100 );
356  strcpy( output_filename, option_source_filename );
357 
358  char* extension = output_filename+strlen(output_filename);
359 
360  // remove any source extension
361  int i;
362  int done = 0;
363  for( i=0; i<SRC_EXT_COUNT; i++)
364  {
365  if( strcasecmp(extension-strlen(SRC_EXT),SRC_EXT)==0 )
366  {
367  strcpy( extension-strlen(SRC_EXT), EXE_EXT );
368  done = 1;
369  break;
370  }
371  }
372 
373  // add executable extension if not done already
374  if( !done )
375  {
376  #ifdef SAFEMODE
377  assert( strlen(EXE_EXT2)!=0 );
378  #endif
379 
380  if( strlen(EXE_EXT)==0 )
381  strcpy( extension, EXE_EXT2 );
382  else
383  strcpy( extension, EXE_EXT );
384  }
385 
386  output_filename_chars = UNFILENAME( output_filename );
387 
388  outfile = fopen( output_filename, "wb" );
389  if( errno ) return new_os_error( output_filename_chars );
390  }
391 
392  #define BUF_SIZE 1024
393  char* buffer[BUF_SIZE];
394  int size;
395 
396  // copy compiler into output file
397  infile = fopen( option_compiler_filename, "rb" );
398  if( errno ) return new_os_error( option_compiler_filename_chars );
399 
400  while( (size = fread( buffer, 1, BUF_SIZE, infile )) )
401  {
402  if( errno ) return new_os_error( option_compiler_filename_chars );
403 
404  fwrite( buffer, 1, size, outfile );
405  if( errno ) return new_os_error( output_filename_chars );
406  }
407  fclose( infile );
408  if( errno ) return new_os_error( option_compiler_filename_chars );
409 
410  // copy source into output file
411  int source_size = 0;
412  infile = fopen( option_source_filename, "rb" );
413  if( errno ) return new_os_error( option_source_filename_chars );
414 
415  while( (size = fread( buffer, 1, BUF_SIZE, infile )) )
416  {
417  if( errno ) return new_os_error( option_source_filename_chars );
418 
419  source_size += size;
420  fwrite( buffer, 1, size, outfile );
421  if( errno ) return new_os_error( output_filename_chars );
422  }
423  fclose( infile );
424  if( errno ) return new_os_error( option_source_filename_chars );
425 
426  // write source size
427  fwrite( &source_size, 1, 4, outfile );
428  if( errno ) return new_os_error( output_filename_chars );
429 
430  // write magic data
432  fwrite( &size, 1, 4, outfile );
433  if( errno ) return new_os_error( output_filename_chars );
434 
435  fclose( outfile );
436  if( errno ) return new_os_error( output_filename_chars );
437 
438  chmod( output_filename, S_IRWXU );
439  if( errno ) return new_os_error( output_filename_chars );
440 
441  DEALLOC( output_filename );
442 
443  return empty_list;
444 }
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))]

Definition at line 458 of file compiler.c.

459 {
460  if( IS_EMPTY(data) ) return data;
461  if( IS_EMPTY(CAR(data)) ) return data;
462 
463  //printf("ensure "); dump_atom(data,1); printf("\n");
464  return data;
465 }
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.

Definition at line 480 of file compiler.c.

481 {
482  #ifdef SAFE_MODE
483  assert( ADDRESS(function) );
484  #endif
485 
486  typedef atom_t(*user_code_t)(); // Lhogho-compiled user code
487 
488  user_code_t func = (user_code_t)ADDRESS(function);
489 
490  //int x;
491  //printf("bin adr=%x\n",(int)func);
492  //for( x=0; x<128; x++ )
493  // {
494  // if( x % 16 ) printf(","); else printf("\n\tdb\t");
495  // printf("$%x", *(((unsigned char*)func)+x));
496  // }
497  //printf("\n");
498  //printf("start executing\n");
499 
500  //printf("******BEFORE******\n");
501  //dump_statistics();
502 
504  atom_t result = func();
506 
507  //printf("******AFTER******\n");
508  //dump_statistics();
509 
510  //printf("result=%x\n",(int)result);
511  //printf("ref=%d\n",REF(result));
512  //printf("result(ref=%d)=",REF(result)); dumpln(result);
513 
514  //printf("before error rootdef="); dump_atom(DEFINITIONS(root),1); printf("\n");
515  //printf("before error rootdef="); dump_atom(TREE(root),1); printf("\n");
516  if( IS_ERROR(result) )
517  {
518  int exit_code = 0;
519  if( ERRCODE(result)!= EXIT_BY_BYE &&
520  ERRCODE(result)!= EXIT_BY_THROW_TOPLEVEL &&
521  ERRCODE(result)!= EXIT_BY_THROW_SYSTEM )
522  {
523  dumpln( result );
524  exit_code = ERRCODE(result);
525  }
526  DEUSE(last_error);
529  return exit_code;
530  }
531  else
532  {
533  DEUSE( result );
534  return 0;
535  }
536 }
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.

Definition at line 550 of file compiler.c.

551 {
552  int exit_code;
553 
554  compiling_code = 1;
555  atom_t x = new_word( source, -1 );
556  atom_t y = trim_shell_comment( x );
557 
558  DEUSE( x );
559  DEUSE( BODY(root) ); BODY(root) = empty_list;
560  DEUSE( TREE(root) ); TREE(root) = empty_list;
564 
565  FULLSOURCE(root) = ( y ); // already used once
566  SOURCE(root) = USE( y );
568  if( IS_ERROR(x) )
569  {
570  exit_code = ERRCODE(x);
571  DEUSE( x );
572  compiling_code = 0;
573  }
574  else
575  {
576  compiling_code = 0;
577  exit_code = run_function(root);
578  //exit_code = 0;
579  }
580 
581  return exit_code;
582 }
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.

Definition at line 608 of file compiler.c.

609 {
610  #ifdef DEBUG_COMPILE
611  printf("<COMPILE> Compile "); dump(NAME(func));
612  if( mode==COMPILE_AS_PROC ) printf(" as procedure\n");
613  if( mode==COMPILE_AS_FUNC ) printf(" as function\n");
614  if( mode==COMPILE_AS_UNKNOWN ) printf(" as unknown\n");
615  #endif
616 
617  need_descr2( func );
618 
619  atom_t x;
620  atom_t y;
621  // if there is not syntax tree of the function
622  // then parse and treeify it first
623  if( IS_EMPTY(TREE(func)) )
624  {
625  y = build_syntax_tree( func );
626  if( IS_ERROR(y) ) return y;
627  }
628 
629  #ifdef DEBUG_COMPILE
630  printf("<COMPILE> Syntax tree built\n");
631  #endif
632 
633  context_t ctx;
634  ctx.size = 0;
635  ctx.generate = NULL;
636  ctx.parent = func;
637  ctx.exit_addr = 0;
638  //printf("SET0 ExAd=%d\n",ctx.exit_addr);
639 
640  // set offset of local variables
641  int offset = BASE_OFFSET_LOCALS-4; // this is the start offset
642  for( x = LOCALS(func); IS_NOT_EMPTY(x); x=CDR(x) )
643  if( IS_VARIABLE(CAR(x)) && OFFSET(CAR(x))==0 && IS_NORMAL(CAR(x)) )
644  {
645  //printf("set offset of "); dump(NAME(CAR(x)));
646  //printf(" to be %d\n",offset);
647  OFFSET(CAR(x)) = offset;
648  offset -= sizeof( atom_t );
649  }
650 
651  #ifdef DEBUG_COMPILE
652  printf("<COMPILE> Pass 1\n");
653  #endif
654 
655  //------------------------------
656  // calculate size of to-be-generated code
657  asm_prologue( &ctx, func, 1 );
658 
659  if( IS_EMPTY(TREE(func)) )
660  asm_empty_body( &ctx );
661  else
662  {
664  y = compile_block( &ctx, TREE(func), mode );
665  if( mode==COMPILE_AS_FUNC )
666  {
667  asm_output( &ctx, TREE(func), 0 ); // simulate OUTPUT
668  }
669  if( IS_ERROR(y) ) return y;
670  }
671  asm_preepilogue( &ctx );
672  ctx.exit_addr = ctx.size;
673  asm_epilogue( &ctx, func, is_macro );
674 
675  #ifdef DEBUG_COMPILE
676  printf("<COMPILE> Pass 1 done!\n");
677  printf("<COMPILE> Code size=%d\n\n",ctx.size);
678  printf("<COMPILE> Pass 2\n");
679  #endif
680 
681  //-----------------------------
682  // allocate memory for code
683  ctx.generate = new_mem( ctx.size );
684  ctx.size = 0;
685  //printf("old exit addr=%8x\n",ctx.exit_addr);
686  ctx.exit_addr = (int)MEMORY(ctx.generate)+ctx.exit_addr;
687  //printf("new base addr=%8x\n",(int)MEMORY(ctx.generate));
688  //printf("new exit addr=%8x\n",ctx.exit_addr);
689 
690 
691  //---------------------------------
692  // generate code for the body of the function
693  asm_prologue( &ctx, func, 1 );
694  if( IS_EMPTY(TREE(func)) )
695  asm_empty_body( &ctx );
696  else
697  {
698  y = compile_block( &ctx, TREE(func), mode );
699  if( mode==COMPILE_AS_FUNC ) asm_output( &ctx, TREE(func), 0 ); // simulate OUTPUT
700  if( IS_ERROR(y) )
701  {
702  DEUSE( ctx.generate );
703  return y;
704  }
705  }
706 
707  asm_preepilogue( &ctx );
708  asm_epilogue( &ctx, func, is_macro );
709 
710  #ifdef DEBUG_COMPILE
711  printf("<COMPILE> Pass 2 done!\n");
712  #endif
713 
714 
715  BINARY(func) = ctx.generate;
716  ADDRESS(func) = (int)MEMORY(BINARY(func));
717 
718  //dumpln( root );
719 
720  // generate code for local functions
721  for( x = LOCALS(func); IS_NOT_EMPTY(x); x=CDR(x) )
722  if( !IS_VARIABLE(CAR(x)) &&
723  !IS_PRIMITIVE(CAR(x)) &&
724  !IS_TAG(CAR(x)) )
725  {
727  if( IS_ERROR(y) ) return y;
728  }
729 
730  return empty_list;
731 }
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.

Definition at line 744 of file compiler.c.

745 {
746  #ifdef DEBUG_COMPILE
747  printf("<COMPILE> Re-compile external "); dump(NAME(func));
748  #endif
749 
750 #ifdef SAFE_MODE
751  assert( IS_EXTERNAL(func) );
752 #endif
753 
754  context_t ctx;
755  ctx.size = 0;
756  ctx.generate = NULL;
757  ctx.parent = func;
758  ctx.exit_addr = 0;
759 
760  #ifdef DEBUG_COMPILE
761  printf("<COMPILE> Pass 1\n");
762  #endif
763 
764  //------------------------------
765  // calculate size of to-be-generated code
766  asm_external_function( &ctx, func );
767 
768  //ctx.exit_addr = ctx.size;
769 
770  #ifdef DEBUG_COMPILE
771  printf("<COMPILE> Pass 1 done!\n");
772  printf("<COMPILE> Code size=%d\n\n",ctx.size);
773  printf("<COMPILE> Pass 2\n");
774  #endif
775 
776  //-----------------------------
777  // allocate memory for code
778  ctx.generate = new_mem( ctx.size );
779  ctx.size = 0;
780 
781 
782  //---------------------------------
783  // generate code for the body of the function
784  asm_external_function( &ctx, func );
785 
786  #ifdef DEBUG_COMPILE
787  printf("<COMPILE> Pass 2 done!\n");
788  #endif
789 
790 
791  DEUSE(BINARY(func));
792  BINARY(func) = ctx.generate;
793  ADDRESS(func) = (int)MEMORY(BINARY(func));
794 
795  return empty_list;
796 }
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.

Definition at line 810 of file compiler.c.

811 {
812  #ifdef DEBUG_COMPILE
813  printf("<COMPILE> Re-compile internal "); dump(NAME(func));
814  #endif
815 
816 #ifdef SAFE_MODE
817  assert( IS_INTERNAL(func) );
818 #endif
819 
820  context_t ctx;
821  ctx.size = 0;
822  ctx.generate = NULL;
823  ctx.parent = func;
824  ctx.exit_addr = 0;
825 
826  #ifdef DEBUG_COMPILE
827  printf("<COMPILE> Pass 1\n");
828  #endif
829 
830  //------------------------------
831  // calculate size of to-be-generated code
832  asm_internal_function( &ctx, static_link, func );
833 
834  //ctx.exit_addr = ctx.size;
835 
836  #ifdef DEBUG_COMPILE
837  printf("<COMPILE> Pass 1 done!\n");
838  printf("<COMPILE> Code size=%d\n\n",ctx.size);
839  printf("<COMPILE> Pass 2\n");
840  #endif
841 
842  //-----------------------------
843  // allocate memory for code
844  ctx.generate = new_mem( ctx.size );
845  ctx.size = 0;
846 
847 
848  //---------------------------------
849  // generate code for the body of the function
850  asm_internal_function( &ctx, static_link, func );
851  #ifdef DEBUG_COMPILE
852  printf("<COMPILE> Pass 2 done!\n");
853  #endif
854 
855 
856  // The address of the function should point to the
857  // newly created trampoline. The memory link should
858  // contain atoms that must be freed when the function
859  // is freed, namely:
860  // - the original memory atom
861  // - the new memory atom
862  // The old memoty atom is needed, because it points
863  // to the old code of the Lhogho function which is
864  // actually used by the new code.
865  BINARY(func) = new_list(ctx.generate,new_list(BINARY(func),empty_list));
866  ADDRESS(func) = (int)MEMORY(ctx.generate);
867 
868  return empty_list;
869 }
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.

Definition at line 885 of file compiler.c.

886 {
887  //printf("is_constant "); dump_atom(lisp,1); printf("\n");
888 
889  // empty list
890  if( IS_EMPTY(lisp) ) return 1;
891 
892  // number?
893  if( IS_INTEGER(lisp) ) return 1;
894  if( IS_FLOAT(lisp) ) return 1;
895 
896  // most non-expressions are constants
897  if( !IS_LIST(lisp) || !IS_EXPRESSION(lisp) )
898  {
899  if( IS_ANY_WORD(lisp)
900  && LENGTH(lisp)>1
901  && *STRING(lisp)==TEXT(':') )
902  {
903  return 0;
904  }
905  return 1;
906  }
907 
908  // if there are more than 1 items then it is not a constant
909  if( IS_NOT_EMPTY(CDR(lisp)) ) return 0;
910 
911  // so we have one element - it could be:
912  // constant - (2)
913  // non-constant - (pi)
914  atom_t elem = CAR(lisp);
915 
916  // (2)
917  if( IS_INTEGER(elem) ) return 1;
918 
919  // (2.5)
920  if( IS_FLOAT(elem) ) return 1;
921 
922  // ([2 5])
923  if( IS_LIST(elem) && !IS_EXPRESSION(elem) ) return 1;
924 
925  // (<not-word>), e.g. error, memory, var, ...
926  if( !IS_ANY_WORD(elem) ) return 0;
927 
928  // ("a)
929  if( LENGTH(elem)>1 && *STRING(elem)==TEXT('"') ) return 1;
930 
931  // (:a)
932  if( LENGTH(elem)>1 && *STRING(elem)==TEXT(':') ) return 0;
933 
934  // (number)
935  float64_t x;
936  if( atom_to_float( elem, &x ) ) return 1;
937 
938  // not a constant
939  return 0;
940 }
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'.

Definition at line 954 of file compiler.c.

955 {
956  //printf("is reference="); dumpln(lisp);
957  // if a word starting with ":" then is a reference
958  if( IS_ANY_WORD(lisp)
959  && LENGTH(lisp)>1
960  && *STRING(lisp)==TEXT(':') )
961  {
962  //printf("it is reference\n");
963  return 1;
964  }
965 
966  // the only other reference is (:a)
967 
968  // non-expressions are not references
969  if( !IS_EXPRESSION(lisp) ) return 0;
970 
971  // empty lists are not references
972  if( IS_EMPTY(lisp) ) return 0;
973 
974  // if there are more than 1 items then it is not a reference
975  if( IS_NOT_EMPTY(CDR(lisp)) ) return 0;
976 
977  //printf("call recursive\n");
978  return is_reference( CAR(lisp) );
979 }
atom_t compile_lisp_const ( context_t ctx,
atom_t  lisp 
)
Parameters
ctxcompilation context
lispconstant to compile
Returns
unbound atom

Compiles a single constant.

Definition at line 993 of file compiler.c.

994 {
995  atom_t value = IS_LIST(lisp)&&IS_EXPRESSION(lisp)?CAR(lisp):lisp;
996  if( ctx->generate )
997  { // create ABC from "ABC if the constant is a word constant
998 
999  //printf("before = "); dumpln(lisp);
1000  if( IS_LIST(lisp) && IS_EXPRESSION(lisp) ) lisp = CAR( lisp ); //Fix for bug #3427526
1001  //printf("after = "); dumpln(lisp);
1002 
1003  if( IS_ANY_WORD( lisp )
1004  && LENGTH(lisp)>0
1005  && *STRING(lisp)==TEXT('"') )
1006  {
1007  value = new_subword( lisp, STRING(lisp)+1, LENGTH(lisp)-1 );
1008  ATOMS(ctx->generate) = new_list( value, ATOMS(ctx->generate) );
1009  }
1010  }
1011  asm_push_atom( ctx, value );
1012  return unbound;
1013 }
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.

Definition at line 1035 of file compiler.c.

1036 {
1037  // remove all inputs which are constant words
1038  // because they are processed automatically
1039  atom_t a;
1040  atom_t b;
1041  for( a=source; IS_NOT_EMPTY(CDR(a)); ) // possibly infinite if atoms are broken
1042  {
1043  atom_t node = CAR(CDR(a));
1044  if( (!IS_ANY_WORD(node)) ||
1045  (LENGTH(node)==0) ||
1046  (*STRING(node)!=TEXT('"')) )
1047  {
1048  a = CDR(a);
1049  continue;
1050  }
1051  // get rid of the next element in the
1052  // list, because it is constant-word
1053  b = CDR(a);
1054  CDR(a) = CDR(b);
1055  CDR(b) = empty_list;
1056  DEUSE( b );
1057  }
1058  // check whether everything is removed
1059  // if yes, then no need to process LOCAL any more
1060  *processed = IS_EMPTY( CDR(source) );
1061  return unbound;
1062 }
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.

Definition at line 1088 of file compiler.c.

1089 {
1090  atom_t params = CDR(source);
1091  atom_t name;
1092  atom_t value_src;
1093  if( is_name )
1094  {
1095  name = CAR(CDR(params));
1096  value_src = params;
1097  }
1098  else
1099  {
1100  name = CAR(params);
1101  value_src = CDR(params);
1102  }
1103 
1104  //printf("value="); dumpln(value_src);
1105  *processed = 1;
1106 
1107  // Check the first input of MAKE. If it is a word constant
1108  // then we have immediate MAKE which is compiled directly.
1109  // Otherwise we have indirect MAKE.
1110 
1111  if( IS_ANY_WORD(name)
1112  && LENGTH(name)>1
1113  && *STRING(name)==TEXT('"') )
1114  {
1115  // We have direct MAKE - i.e. we know the name of the
1116  // variable which value is changed. Generate code which
1117  // will push the absolute address of the variable.
1118  atom_t real_name = new_subword( name, STRING(name)+1, LENGTH(name)-1 );
1119  atom_t var = find_var( real_name, ctx->parent );
1120  if( var )
1121  {
1122  //printf("found var "); dump_atom(NAME(var),1); printf(" parent="); dumpln(NAME(PARENT(var)));
1123  //printf("--- isglobal=%d isnormal=%d isruntime=%d\n",IS_GLOBAL(var),IS_NORMAL(var),IS_RUNTIME(var));
1124  if( !IS_VARIABLE( var ) )
1125  {
1126  DEUSE( real_name );
1127  return new_error( ERROR_NOT_A_VAR, name );
1128  }
1129  // direct make + existing variable
1130  // push <value>
1131  atom_t y = compile_expr( ctx, value_src, COMPILE_AS_FUNC );
1132  if( IS_ERROR(y) ) return y;
1133  asm_make_direct( ctx, var, source );
1134  }
1135  else
1136  {
1137  // direct make + NON-existing variable
1138  *processed = 0;
1139  }
1140  DEUSE( real_name );
1141  }
1142  else
1143  {
1144  // indirect make
1145  // leave handling for rt_make
1146  //printf("not found var\n");
1147  *processed = 0;
1148  }
1149 
1150  return unbound;
1151 }
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.

Definition at line 1164 of file compiler.c.

1165 {
1166  atom_t params = CDR(source);
1167  atom_t value_src = params;
1168 
1169  atom_t result = compile_expr( ctx, value_src, COMPILE_AS_FUNC );
1170  asm_output( ctx, source, 1 ); // true output
1171 
1172  return result;
1173 }
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.

Definition at line 1187 of file compiler.c.

1188 {
1189  atom_t params = CDR(source);
1190  atom_t value_src = params;
1191 
1192  atom_t result = compile_expr( ctx, value_src, COMPILE_AS_UNKNOWN );
1193  asm_push_result( ctx );
1194  asm_output( ctx, source, 1 ); // true output
1195 
1196  return result;
1197 }
atom_t compile_stop ( context_t ctx,
atom_t  source 
)
Parameters
ctxcompilation context
sourceSTOP's source
Returns
unbound atom

Compiles a STOP statement.

Definition at line 1211 of file compiler.c.

1212 {
1213  asm_stop( ctx, source );
1214  return unbound;
1215 }
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.

Definition at line 1640 of file compiler.c.

1641 {
1642  atom_t commands = CAR(CDR(source));
1643 
1644  //printf("condition = "); dumpln(condition_lisp);
1645  //printf("commands = "); dumpln(commands_lisp);
1646 
1647  int skip_branch = asm_test_prologue( ctx, criteria );
1648 
1649  atom_t y = compile_block( ctx, commands, COMPILE_AS_PROC );
1650  if( IS_ERROR(y) ) return y;
1651 
1652  asm_fix( ctx, skip_branch );
1653 
1654  return unbound;
1655 }
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.

Definition at line 1771 of file compiler.c.

1772 {
1773  atom_t result = unbound;
1774 
1775  //printf("in===="); dumpln(source);
1776  atom_t name;
1777  if( IS_ANY_WORD(source) )
1778  name = source;
1779  else
1780  name = CAR(source);
1781  atom_t real_name = new_subword( name, STRING(name)+1, LENGTH(name)-1 );
1782  atom_t var = find_var( real_name, ctx->parent );
1783  if( var && IS_NORMAL(var) )
1784  {
1785  if( IS_VARIABLE( var ) )
1786  {
1787  // existing variable
1788  asm_reference( ctx, var, source, 1 );
1789  }
1790  else
1791  result = new_error( ERROR_NOT_A_VAR, name );
1792  }
1793  else
1794  {
1795  // NON-existing variable
1796  compile_lisp_const( ctx, name );
1797  asm_runtime_reference( ctx );
1798  asm_pop_atom( ctx );
1799  asm_push_result( ctx );
1800  }
1801  DEUSE( real_name );
1802 
1803  return result;
1804 }

Variable Documentation

int running_compiled_code

Definition at line 138 of file compiler.c.

int compiling_code

Definition at line 139 of file compiler.c.

char* source_extensions[] = { ".lgo", ".log", ".lg", ".logo", ".lho", ".lhogho" }

Definition at line 141 of file compiler.c.


[ HOME | INDEX | ATOMS | VARS | REFERENCE ]
Lhogho Developer's Documentation
Wed Jul 10 2013