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

Defines

#define test_elem_and_destroy_if_error(elem, list)
 Check if element is error and if destroy the list.
#define ARGUMENT   *pdata
#define EACH_ARGUMENT   pdata=(atom_t*)(&data+data); (int*)pdata>&data; pdata--
#define SIGN(X)   ((X == 0) ? 0 : (X < 0 ? -1 : 1))
#define ZERO_PRECISION   1e-10
#define MAX_NUMBER_WORD_LENGTH   64
#define MAX_WORD_LENGTH   4096
#define CHECK_PARAM(param)   if( IS_ERROR(param) ) RETURN(USE(param))
#define rt_makechk   __attribute__((used,noinline,regparm(0),stdcall)) rt_makechk
#define rt_cmdchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_cmdchk
#define rt_exprchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_exprchk
#define rt_boolchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_boolchk
#define rt_funchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_funchk
#define rt_repchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_repchk
#define rt_forchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_forchk
#define rt_dump   __attribute__((used,noinline,regparm(0),stdcall)) rt_dump
#define rt_predump   __attribute__((used,noinline,regparm(0),stdcall)) rt_predump
#define rt_whlchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_whlchk
#define void   void __attribute__ ((used,noinline,regparm(0),stdcall))
#define void   atom_t __attribute__ ((used,noinline,regparm(0),stdcall))
#define void   void __attribute__ ((used,noinline,regparm(0),stdcall))
#define rt_use_var   __attribute__((used,noinline,regparm(0),stdcall)) rt_use_var
#define rt_catchchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_catchchk
#define rt_runresult_fix   __attribute__((used,noinline,regparm(0),stdcall)) rt_runresult_fix

Functions

void rt_set_var_value (int static_link, atom_t parent, atom_t var, atom_t value)
 sets var's value in the local stacks
void init_runtime ()
 initializes the Runtime module
void finit_runtime ()
 finalizes the Runtime module
int find_file_by_filename (char *filename)
 search log by filename
int find_file_by_handle (FILE *handle)
 search log by handlee
atom_t rt_makechk (atom_t source, atom_t data)
 checks for valid result of a MAKE command
atom_t rt_cmdchk (atom_t source, atom_t data)
 checks for valid result of a command
atom_t rt_exprchk (atom_t source, atom_t data)
 checks for valid result of an expression
atom_t rt_boolchk (atom_t source, atom_t data)
 checks for valid boolean value
atom_t rt_funchk (atom_t source, atom_t data)
 checks for valid result of a function
atom_t rt_repchk (atom_t source, atom_t data)
 checks for valid repetition count
atom_t rt_forchk (atom_t source, atom_t *step_value, atom_t step, atom_t to, atom_t from)
 checks for valid repetition count
atom_t rt_print (atom_t pdl, atom_t pwl, atom_t fpp, int data)
 implementation of primitive PRINT
atom_t rt_plus (int count, atom_t data2, atom_t data1)
 implementation of primitive operator +
atom_t rt_minus (int count, atom_t data2, atom_t data1)
 implementation of primitive operator -
atom_t rt_mul (atom_t data2, atom_t data1)
 implementation of primitive operator *
atom_t rt_div (atom_t data2, atom_t data1)
 implementation of primitive operator /
atom_t rt_sum (int data)
 implementation of aritmetic primitive SUM
atom_t rt_difference (atom_t data2, atom_t data1)
 implementation of aritmetic primitive DIFFERENCE
atom_t rt_unminus (atom_t data)
 implementation of aritmetic unary primitive MINUS
atom_t rt_product (int data)
 implementation of aritmetic primitive PRODUCT
atom_t rt_remainder (atom_t data2, atom_t data1)
 implementation of aritmetic primitive REMAINDER
atom_t rt_int (atom_t data)
 implementation of aritmetic unary primitive INT
atom_t rt_round (atom_t data)
 implementation of aritmetic unary primitive ROUND
atom_t rt_sqrt (atom_t data)
 implementation of aritmetic unary primitive SQRT
atom_t rt_power (atom_t power, atom_t base)
 implementation of aritmetic primitive POWER
atom_t rt_exp (atom_t power)
 implementation of aritmetic primitive EXP
atom_t rt_log10 (atom_t data)
 implementation of aritmetic primitive LOG10
atom_t rt_ln (atom_t data)
 implementation of aritmetic primitive LN
atom_t rt_abs (atom_t data)
 implementation of aritmetic primitive ABS
atom_t rt_pi (void)
 implementation of aritmetic primitive PI
atom_t rt_sin (atom_t data)
 implementation of aritmetic primitive SIN
atom_t rt_radsin (atom_t data)
 implementation of aritmetic primitive RADSIN
atom_t rt_cos (atom_t data)
 implementation of aritmetic primitive COS
atom_t rt_radcos (atom_t data)
 implementation of aritmetic primitive RADCOS
atom_t rt_arctan (int count, atom_t data2, atom_t data1)
 implementation of aritmetic primitive ARCTAN
atom_t rt_radarctan (int count, atom_t data2, atom_t data1)
 implementation of aritmetic primitive RADARCTAN
atom_t rt_make (int static_link, atom_t parent, atom_t value, atom_t name)
 implementation of primitive command MAKE
atom_t rt_name (int static_link, atom_t parent, atom_t name, atom_t value)
 implementation of primitive command NAME
atom_t rt_local (int static_link, atom_t parent, int data)
 dummy implementation of primitive command LOCAL
int num_compare (float64_t x, float64_t y)
 compares two numbers.
int word_compare (int cip, chars_t w1, int w1_len, chars_t w2, int w2_len)
 compares two words.
int atom_equal (atom_t cip, atom_t data2, atom_t data1)
 compares two atoms.
int list_equal (atom_t cip, atom_t data1, atom_t data2)
 compares two lists.
atom_t rt_equal (atom_t cip, atom_t data2, atom_t data1)
 implementation compare operation EQUALP
atom_t rt_nequal (atom_t cip, atom_t data2, atom_t data1)
 implementation compare operation NOTEQUALP
atom_t rt_less (atom_t data2, atom_t data1)
 implementation compare operation LESSP
atom_t rt_more (atom_t data2, atom_t data1)
 implementation compare operation GREATERP
atom_t rt_lesseq (atom_t data2, atom_t data1)
 implementation compare operation LESSEQUALP
atom_t rt_moreeq (atom_t data2, atom_t data1)
 implementation compare operation GREATEREQUALP
atom_t rt_before (atom_t cip, atom_t data2, atom_t data1)
 implementation compare operation BEFOREP
atom_t rt_output (atom_t data)
 dummy implementation of primitive command OUTPUT
atom_t rt_maybeoutput (atom_t data)
 dummy implementation of primitive command MAYBEOUTPUT
atom_t rt_stop ()
 dummy implementation of primitive command STOP
atom_t rt_dump (atom_t source)
 dump source command
atom_t rt_predump (atom_t source)
 dump source command
atom_t rt_and (int data)
 implementation of boolean primitive AND
atom_t rt_or (int data)
 implementation of boolean primitive OR
atom_t rt_not (atom_t data)
 implementation of boolean primitive NOT
atom_t rt_ignore (atom_t data)
 implementation of primitive IGNORE
atom_t rt_first (atom_t data)
 implementation of primitive FIRST
atom_t rt_butfirst (atom_t data)
 implementation of primitive BUTFIRST
atom_t rt_firsts (atom_t data)
 implementation of primitive FIRSTS
atom_t rt_butfirsts (atom_t data)
 implementation of primitive BUTFIRSTS and BFS
atom_t rt_last (atom_t data)
 implementation of primitive LAST
atom_t rt_butlast (atom_t data)
 implementation of primitive BUTALST
atom_t rt_item (atom_t data, atom_t index)
 implementation of primitive ITEM
atom_t rt_if (int count)
 dummy implementation of primitive command IF
atom_t rt_repeat (atom_t repcount, atom_t commands)
 dummy implementation of primitive command REPEAT
atom_t rt_while (atom_t condition, atom_t commands)
 dummy implementation of primitive command WHILE
atom_t rt_dowhile (atom_t commands, atom_t condition)
atom_t rt_until (atom_t condition, atom_t commands)
 dummy implementation of primitive command UNTIL
atom_t rt_dountil (atom_t commands, atom_t condition)
 dummy implementation of primitive command UNTIL
atom_t rt_whlchk (atom_t source, atom_t data)
 checks for valid while condition
void rt_repeat_enter (int frame, int count)
 initializes a repeat loop
void rt_repeat_exit (int frame)
 finalizes a repeat loop
atom_t rt_repcount (int frame)
 implementation of primitive function REPCOUNT
atom_t rt_forever (atom_t commands)
 dummy implementation of primitive command FOREVER
void rt_forever_enter (int frame)
 initializes a forever loop
atom_t rt_parse (atom_t data)
 implementation of PARSE
atom_t rt_runparse (atom_t data)
 implementation of RUNPARSE
atom_t rt_wordp (atom_t data)
 implementation of WORDP
atom_t rt_listp (atom_t data)
 implementation of LISTP
atom_t rt_numberp (atom_t data)
 implementation of NUMBERP
atom_t rt_empty (atom_t data)
 implementation of EMPTYP
atom_t rt_memberp (atom_t cip, atom_t data, atom_t elem)
 implementation of MEMBERP
atom_t rt_word (int data)
 implementation of constructor primitive WORD
atom_t rt_list (int data)
 implementation of constructor primitive LIST
atom_t rt_sent (int data)
 implementation of constructor primitive SE
atom_t rt_fput (atom_t data2, atom_t data1)
 implementation of constructor primitive FPUT
atom_t rt_lput (atom_t data2, atom_t data1)
 implementation of constructor primitive LPUT
atom_t rt_count (atom_t data)
 implementation of querie primitive COUNT
atom_t rt_char (atom_t data)
 implementation of querie primitive CHAR
atom_t rt_ascii (atom_t data)
 implementation of querie primitive ASCII
atom_t rt_lower (atom_t data)
 implementation of querie primitive LOWERCASE
atom_t rt_upper (atom_t data)
 implementation of querie primitive UPPERCASE
atom_t rt_member (atom_t cip, atom_t data, atom_t elem)
 implementation of MEMBER
atom_t rt_iseq (atom_t to, atom_t from)
 implementation of ISEQ
atom_t rt_rseq (atom_t count, atom_t to, atom_t from)
 implementation of RSEQ
atom_t rt_random (int count, atom_t data2, atom_t data1)
 implementation of aritmetic primitive RANDOM
atom_t rt_rerandom (int count, atom_t seed)
 implementation of primitive RERANDOM
atom_t rt_show (atom_t pdl, atom_t pwl, atom_t fpp, int data)
 implementation of primitive SHOW
atom_t rt_type (atom_t pdl, atom_t pwl, atom_t fpp, int data)
 implementation of primitive TYPE
atom_t rt_form (atom_t precision, atom_t width, atom_t num)
 implementation of primitive FORM
char_t get_format (chars_t string)
 extracts format specifier
atom_t rt_format (atom_t format, atom_t data)
 implementation of primitive FORMAT
atom_t rt_formattime (atom_t format, atom_t data)
 implementation of primitive FORMATTIME
atom_t rt_definedp (int static_link, atom_t parent, atom_t data)
 implementation of DEFINED?
atom_t rt_primitivep (int static_link, atom_t parent, atom_t data)
 implementation of PRIMITIVE?
atom_t rt_namep (int static_link, atom_t parent, atom_t data)
 implementation of NAME?
atom_t rt_procedurep (int static_link, atom_t parent, atom_t data)
 implementation of PROCEDURE?
atom_t rt_var_value (int static_link, atom_t parent, atom_t var)
 searches var's value in the local stacks
atom_t rt_use_var (atom_t source, atom_t value)
 checks the value of a variable
atom_t rt_thing (int static_link, atom_t parent, atom_t data)
 implementation of THING
atom_t rt_reference (int static_link, atom_t parent, atom_t data)
 implementation of :
atom_t rt_bye (void)
 implementation of command BYE
atom_t rt_wait (atom_t time)
 implementation of command WAIT
atom_t rt_ashift (atom_t bits, atom_t num)
 implementation of primitive command ASHIFT
atom_t rt_lshift (atom_t bits, atom_t num)
 implementation of primitive command LSHIFT
atom_t rt_bitand (int data)
 implementation of primitive command BITAND
atom_t rt_bitor (int data)
 implementation of primitive command BITOR
atom_t rt_bitxor (int data)
 implementation of primitive command BITXOR
atom_t rt_bitnot (atom_t data)
 implementation of primitive command BITNOT
atom_t rt_pick (atom_t list)
 implementation of primitive command PICK
atom_t rt_remdup (atom_t cip, atom_t data)
 implementation of primitive command REMDUP
atom_t rt_remove (atom_t cip, atom_t data, atom_t elem)
 implementation of primitive command REMOVE
atom_t rt_reverse (atom_t data)
 implementation of primitive command REVERSE
atom_t rt_rawascii (atom_t data)
 implementation of querie primitive RAWASCII
atom_t rt_gensym ()
 implements primitive function GENSYM
atom_t rt_substringp (atom_t cip, atom_t data2, atom_t data1)
 implements primitive predicate SUBSTRINGP
atom_t rt_substring (atom_t cip, atom_t data2, atom_t data1)
 implements primitive SUBSTRING
atom_t rt_combine (atom_t data2, atom_t data1)
 implementation of constructor primitive COMBINE
atom_t rt_quoted (atom_t data)
 implementation of primitive function QUOTED
atom_t rt_throw (int count, atom_t data1, atom_t data2)
 implementation of primitive THROW
atom_t rt_catch (atom_t commands, atom_t tag)
 dummy implementation of primitive command CATCH
atom_t rt_catchchk (int status, atom_t tag, atom_t data)
 checks for valid result of a catch
atom_t rt_error ()
 implementation of primitive function ERROR
atom_t rt_tag ()
 dummy implementation of primitive command TAG
atom_t rt_goto (int static_link, atom_t parent, atom_t data, atom_t source)
 implementation of primitive command GOTO
atom_t rt_iftrue (atom_t commands)
 dummy implementation of primitive command IFTRUE
atom_t rt_iffalse (atom_t commands)
 dummy implementation of primitive command IFFALSE
atom_t rt_test (atom_t condition, int frame)
 implementation of primitive command TEST
atom_t rt_backslashedp (atom_t data)
 implementation of primitive BACKSLASHED?
atom_t rt_text (int static_link, atom_t parent, atom_t data)
 implementation of TEXT
atom_t rt_fulltext (int static_link, atom_t parent, atom_t data)
 implementation of FULLTEXT
atom_t rt_run (int static_link, atom_t parent, atom_t data, int mode)
 implementation of RUN
atom_t rt_runmacro (int static_link, atom_t parent, atom_t data, int mode)
 implementation of RUNMACRO
atom_t rt_runresult (int static_link, atom_t parent, atom_t data)
 implementation of RUNRESULT
atom_t rt_runresult_fix (atom_t data)
 fixes the result of RUNRESULT
atom_t rt_define (int static_link, atom_t parent, atom_t value, atom_t name)
 implementation of primitive command DEFINE
atom_t rt_for (atom_t body, atom_t limits, atom_t var)
 dummy implementation of primitive command FOR
atom_t rt_libload (atom_t data)
 implementation of primitive LIBLOAD
atom_t rt_libfree (atom_t data)
 implementation of primitive LIBFREE
atom_t rt_blocksize (int static_link, atom_t parent, atom_t prototype)
 implementation of PACKSIZE
atom_t rt_listtoblock (int static_link, atom_t parent, atom_t prototype, atom_t data)
 implementation of LISTTOBLOCK
atom_t rt_blocktolist (int static_link, atom_t parent, atom_t prototype, atom_t data)
 implementation of PACK
atom_t rt_dataaddr (atom_t data)
 implementation of DATAADDR
atom_t rt_listintoblock (int static_link, atom_t parent, atom_t prototype, atom_t dest, atom_t data)
 implementation of PACKTO
atom_t rt_funcaddr (int static_link, atom_t parent, atom_t data)
 implementation of FUNVADDR
atom_t rt_external (int static_link, atom_t parent, atom_t handle, atom_t prototype, atom_t name)
 implementation of EXTERNAL
atom_t rt_internal (int static_link, atom_t parent, atom_t prototype, atom_t name)
 implementation of INTERNAL
atom_t rt_stackframe (int static_link, atom_t parent, atom_t offset, atom_t frame)
 implementation of _STACKFRAME
atom_t rt_stackframeatom (int static_link, atom_t parent, atom_t offset, atom_t frame)
 implementation of _STACKFRAMEATOM
atom_t rt_int3 ()
 dummy implementation of debug command _INT3
atom_t rt_load (atom_t data)
 implementation of LOAD
atom_t rt_commandline ()
 implementation of COMMANDLINE
atom_t rt_openfile_mode (atom_t filename, char *mode, int call_mode)
 used by OPEN* functions
atom_t rt_openfile (atom_t mode, atom_t filename, int call_mode)
 implementation of OPENFILE
atom_t get_file_index (atom_t file, int *index)
 get file index
atom_t rt_closefile (atom_t file)
 implementation of CLOSEFILE
atom_t rt_readblock (int static_link, atom_t parent, atom_t size)
 implementation of READBLOCK
atom_t rt_readinblock (atom_t block, int call_mode)
 implementation of READINBLOCK
atom_t rt_writeblock (atom_t data)
 implementation of WRITEBLOCK
atom_t rt_readchar (void)
 implementation of primitive function readchar
atom_t rt_readchars (atom_t data)
 implementation of primitive function readchars
atom_t rt_readrawline (void)
 implementation of primitive function readrawline
atom_t rt_readword (void)
 implementation of primitive function readword
atom_t rt_readlist (void)
 implementation of primitive function readlist
atom_t rt_getenv (atom_t data)
 implementation of GETENV
atom_t rt_getenvs ()
 implementation of GETENVS
atom_t rt_eofp (void)
 implementation of primitive function eof?
atom_t rt_currentfolder (void)
 implementation of primitive function currentfolder
atom_t rt_makefolder (atom_t name)
 implementation of primitive function makefolder
atom_t rt_erasefolder (atom_t name)
 implementation of primitive function erasefolder
atom_t rt_changefolder (atom_t name)
 implementation of primitive function changefolder
atom_t rt_folderp (atom_t name)
 implementation of primitive function folder?
atom_t rt_renamefolder_or_file (atom_t toname, atom_t fromname, int folders)
 implementation of primitive function renamefolder
atom_t rt_renamefolder (atom_t toname, atom_t fromname)
 implementation of primitive function renamefolder
atom_t rt_renamefile (atom_t toname, atom_t fromname)
 implementation of primitive function renamefile
atom_t rt_folders_or_files (atom_t name, int folders)
 scans a folder
atom_t rt_folders (atom_t name)
 implementation of primitive function folders
atom_t rt_files (atom_t name)
 implementation of primitive function files
atom_t rt_erasefile (atom_t name)
 implementation of primitive function erasefile
atom_t rt_filep (atom_t name)
 implementation of primitive function file?
atom_t rt_filesize (atom_t name)
 implementation of primitive function filesize
atom_t rt_filetimes (atom_t name)
 implementation of primitive function filetimes
atom_t rt_openread (atom_t name, int call_mode)
 implementation of primitive function openread
atom_t rt_openwrite (atom_t name, int call_mode)
 implementation of primitive function openwrite
atom_t rt_openappend (atom_t name, int call_mode)
 implementation of primitive function openappend
atom_t rt_openupdate (atom_t name, int call_mode)
 implementation of primitive function openupdate
atom_t rt_setread (atom_t file)
 implementation of SETREAD
atom_t rt_setwrite (atom_t file)
 implementation of SETWRITE
atom_t rt_reader ()
 implementation of READER
atom_t rt_writer ()
 implementation of WRITER
atom_t rt_allopen ()
 implementation of ALLOPEN
atom_t rt_closeall ()
 implementation of CLOSEALL
atom_t rt_setreadpos (atom_t pos)
 implementation of SETREADPOS
atom_t rt_readpos ()
 implementation of READPOS
atom_t rt_setwritepos (atom_t pos)
 implementation of SETWRITEPOS
atom_t rt_writepos ()
 implementation of WRITEPOS
atom_t rt_timezone ()
 implementation of TIMEZONE

Variables

char * file_names [FOPEN_MAX] = { [0 ... (FOPEN_MAX-1)]=NULL }
 Array of names of opened files.
FILE * file_handles [FOPEN_MAX] = { [0 ... (FOPEN_MAX-1)]=NULL }
 Array of handles of opened files.

Define Documentation

#define test_elem_and_destroy_if_error (   elem,
  list 
)
Value:
{                                                           \
    if (IS_ERROR(elem))                                     \
    {                                                       \
      DEUSE (list);                                       \
      RETURN (elem);                                      \
    }                                                       \
  }
#define ARGUMENT   *pdata
#define EACH_ARGUMENT   pdata=(atom_t*)(&data+data); (int*)pdata>&data; pdata--
#define SIGN (   X)    ((X == 0) ? 0 : (X < 0 ? -1 : 1))
#define ZERO_PRECISION   1e-10
#define MAX_NUMBER_WORD_LENGTH   64
#define MAX_WORD_LENGTH   4096
#define CHECK_PARAM (   param)    if( IS_ERROR(param) ) RETURN(USE(param))
#define rt_makechk   __attribute__((used,noinline,regparm(0),stdcall)) rt_makechk
#define rt_cmdchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_cmdchk
#define rt_exprchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_exprchk
#define rt_boolchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_boolchk
#define rt_funchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_funchk
#define rt_repchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_repchk
#define rt_forchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_forchk
#define rt_dump   __attribute__((used,noinline,regparm(0),stdcall)) rt_dump
#define rt_predump   __attribute__((used,noinline,regparm(0),stdcall)) rt_predump
#define rt_whlchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_whlchk
#define void   void __attribute__ ((used,noinline,regparm(0),stdcall))
#define void   atom_t __attribute__ ((used,noinline,regparm(0),stdcall))
#define void   void __attribute__ ((used,noinline,regparm(0),stdcall))
#define rt_use_var   __attribute__((used,noinline,regparm(0),stdcall)) rt_use_var
#define rt_catchchk   __attribute__((used,noinline,regparm(0),stdcall)) rt_catchchk
#define rt_runresult_fix   __attribute__((used,noinline,regparm(0),stdcall)) rt_runresult_fix

Function Documentation

void rt_set_var_value ( int  static_link,
atom_t  parent,
atom_t  var,
atom_t  value 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
varthe variable
valuethe value

This function looks for a variable somewhere in stack frames and sets it value. If the variable is global do not scan the stack.

  {
    //printf("VALUE IS VAR ATOM\n");
    //printf("var = "); dumpln(var);
    //printf("old value="); dumpln(VALUE(var));
    //printf("new value="); dumpln(value);
    DEUSE( VALUE( var ) );
    VALUE( var ) = USE( value );
    //printf("new value="); dumpln(VALUE(var));
    return;
  }

  //printf("VALUE IN STACK\n");
  int i;
  for (i = 0; i < LEVEL( parent ) - LEVEL( var ) + 1; i++)
  static_link = *(int*) ((char*) static_link + BASE_OFFSET_STATIC);

  atom_t* varptr = (atom_t*) ((char*) static_link + OFFSET( var ));
  DEUSE( *varptr );
  *varptr = USE( value );
}



//===================================================

So far nothing to be initialized

{

Deallocates all names of unclosed files and closes them.

{
int find_file_by_filename ( char *  filename)
Parameters:
filenamename of a file
Returns:
index of found filename; -1 if not found

Searches file_names for the string in filename and return its index in the array. If not found returns -1.

{
int find_file_by_handle ( FILE *  handle)
Parameters:
handlehandle of a file
Returns:
index of found file; -1 if not found

Searches file_handles for a given handle and return its index in the array. If not found returns -1.

{
atom_t rt_makechk ( atom_t  source,
atom_t  data 
)
Parameters:
sourcesource of the command
datavalue to check
Returns:
error or unbound atom

Checks whether the result of a MAKE is valid. Returns error atom if the result is error or unbound. Otherwise returns unbound atom. The source parameter points to the source where the make is called. It is used to locate the error position in case of errors.

  {
    outter( TEXT( "DONE " ), -1 );
    dumpln( source );
  }
#endif

  if (IS_UNBOUND( data ))
  {
    return new_error( ERROR_MISSING_VALUE, source );
  }

  if (IS_ERROR( data ))
  {
    add_error_source( data, source );
    return USE( data );
  }

  // this unbound should not be USE()'d, because
  // it is used only for checking -- it is not
  // stored anywhere
  return unbound;
}




//===================================================
atom_t rt_cmdchk ( atom_t  source,
atom_t  data 
)
Parameters:
sourcesource of the command
datavalue to check
Returns:
error or unbound atom

Checks whether the result of a command is valid. Returns error atom if the result is error or not unbound. Otherwise returns unbound atom. The source parameter points to the source where the command is called. It is used to locate the error position in case of errors.

  {
    outter( TEXT( "DONE " ), -1 );
    dumpln( source );
  }
#endif
  if (IS_UNBOUND( data ) || IS_STOPPED( data ))
  return data;

  if (IS_ERROR( data ))
  {
    add_error_source( data, source );
    return USE( data );
  }

  DEUSE( data );
  return new_error( ERROR_UNUSED_VALUE, source );
}




//===================================================
atom_t rt_exprchk ( atom_t  source,
atom_t  data 
)
Parameters:
sourcesource of the expression
datavalue to check
Returns:
error or unbound atom

Checks whether the result of an expression is valid. Actually any result is valid. Thus this function is used only to add new error position or dump the source if -Zrt option is on.

  {
    outter( TEXT( "DONE " ), -1 );
    dumpln( source );
  }
#endif

  if (IS_ERROR( data ))
  {
    add_error_source( USE( data ), source );
  }

  return data;
}




//===================================================
atom_t rt_boolchk ( atom_t  source,
atom_t  data 
)
Parameters:
sourcesource of the command
datavalue to check
Returns:
error, true or false atom

Checks whether the value is true or false. If not then returns an error atom.

  {
    add_error_source( data, source );
    return USE( data );
  }

  int b;
  if (atom_to_boolean( data, &b ))
  {
    DEUSE( data );
    return ( false_true[b]);
  }

  DEUSE( data );
  return new_error( ERROR_BOOLEAN_EXPECTED, source );
}




//===================================================
atom_t rt_funchk ( atom_t  source,
atom_t  data 
)
Parameters:
datavalue to check
sourcesource of the function
Returns:
error or unbound atom

Checks whether the result of a function is valid. Returns error atom if the result is error or unbound. Otherwise returns the same atom. The source parameter points to the source where the function is called. It is used to locate the error position in case of errors.

  {
    outter( TEXT( "EVAL " ), -1 );
    dump( source );
    outter( TEXT( " = " ), 3 );
    dumpln( data );
  }
#endif

  if (IS_ERROR( data ))
  {
    add_error_source( data, source );
    return ( USE(data) );
  }

  if (!IS_UNBOUND( data ))
  return data;


  DEUSE( data );
  return new_error( ERROR_MISSING_VALUE, source );
}




//===================================================
atom_t rt_repchk ( atom_t  source,
atom_t  data 
)
Parameters:
datavalue to check
sourcesource of the expression
Returns:
error or unbound atom

Checks whether the number of repetition in a repeat command is valid. Returns error atom if the result is error, unbound or invalid. Otherwise returns an integer atom containing the number of repetitions. The source parameter points to the source where the expression is called. It is used to locate the error position in case of errors.

  {
    add_error_source( data, source );
    return USE( data );
  }

  if (IS_UNBOUND( data ))
  {
    DEUSE( data );
    return new_error( ERROR_MISSING_VALUE, source );
  }

  int64_t cnt;
  if (!atom_to_int( data, &cnt ))
  {
    DEUSE( data );
    return new_error( ERROR_NOT_AN_INTEGER, source );
  }

  DEUSE( data );

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

  if (cnt < 0)
  return new_error( ERROR_TOO_SMALL_NUMBER, source );

  return new_integer( cnt );
}




//===================================================
atom_t rt_forchk ( atom_t  source,
atom_t step_value,
atom_t  step,
atom_t  to,
atom_t  from 
)
Parameters:
frominitial value
tofinal value
stepstep value (could be UNBOUND)
step_valuepointer to step value
sourcesource of the expression
Returns:
error or unbound atom

Calculates the number of repetition in a for command. Returns error atom if the result is error, unbound or invalid. Otherwise returns an integer atom containing the number of repetitions. The source parameter points to the source where the expression is called. It is used to locate the error position in case of errors.

  {
    DEUSE( to );
    DEUSE( step );
    add_error_source( from, source );
    return USE( from );
  }

  if (IS_UNBOUND( from ))
  {
    //DEUSE( from ); /// ???
    DEUSE( to );
    DEUSE( step );
    return new_error( ERROR_MISSING_VALUE, source );
  }

  if (!atom_to_float( from, &from_f ))
  {
    //DEUSE( from );
    DEUSE( to );
    DEUSE( step );
    return new_error( ERROR_NOT_A_NUMBER, source );
  }


  // process the final value
  if (IS_ERROR( to ))
  {
    DEUSE( from );
    DEUSE( step );
    add_error_source( to, CDR( source ) );
    return USE( to );
  }

  if (IS_UNBOUND( to ))
  {
    DEUSE( from );
    //DEUSE( to );
    DEUSE( step );
    return new_error( ERROR_MISSING_VALUE, CDR( source ) );
  }

  if (!atom_to_float( to, &to_f ))
  {
    //DEUSE( from );
    DEUSE( to );
    DEUSE( step );
    return new_error( ERROR_NOT_A_NUMBER, CDR( source ) );
  }



  // process the step
  if (IS_ERROR( step ))
  {
    DEUSE( from );
    DEUSE( to );
    add_error_source( step, CDR( CDR( source ) ) );
    return USE( step );
  }

  if (IS_UNBOUND( step ))
  {
    step_f = (to_f >= from_f) ? 1 : -1;
  }
  else
  if (!atom_to_float( step, &step_f ))
  {
    //DEUSE( from );
    DEUSE( to );
    DEUSE( step );
    return new_error( ERROR_NOT_A_NUMBER, CDR( CDR( source ) ) );
  }

  DEUSE( *step_value );
  *step_value = new_float( step_f );
  //printf("FOR from=%f to=%f step=%f\n",from_f,to_f,step_f);

  int64_t cnt;

  if ((to_f >= from_f) && (step_f > 0))
  cnt = floor( (to_f - from_f) / step_f ) + 1;
  else
  if ((to_f <= from_f) && (step_f < 0))
  cnt = floor( (to_f - from_f) / step_f ) + 1;
  else
  cnt = 0;

  //DEUSE( from );
  DEUSE( to );
  DEUSE( step );

  //printf("  repeat count=%Ld\n",cnt);
  //printf("---<<< end of RT_FOR_CHK >>>---\n");

  return new_integer( cnt );
}




//===================================================
atom_t rt_print ( atom_t  pdl,
atom_t  pwl,
atom_t  fpp,
int  data 
)
Parameters:
pdlvalue of PRINTDEPTHLIMIT
pwlvalue of PRINTWIDTHLIMIT
fppvalue of FULLPRINTP
datanumber of inputs of PRINT

Implements the primitive PRINT. The only input contains the number of inputs which are pulled out from the stack.

  {
    CHECK_PARAM( ARGUMENT );
    dump( ARGUMENT );
    outter( TEXT( " " ), 1 );
  };
  outter( TEXT( "\n" ), 1 );
  RETURN( unbound );
}




//===================================================
atom_t rt_plus ( int  count,
atom_t  data2,
atom_t  data1 
)
Parameters:
countnumber of inputs of +
data1first input
data2second input
Returns:
Number atom - sum of its arguments

Implements the primitive operator +. If + is used as infix operator, then count=2, otherwise count=1 and only data2 input is used.

{
atom_t rt_minus ( int  count,
atom_t  data2,
atom_t  data1 
)
Parameters:
countnumber of inputs of -
data1first input
data2second input
Returns:
Number atom - diference of its arguments

Implements the primitive operator -. If - is used as infix operator, then count=2, otherwise count=1 and only data2 input is used.

{
atom_t rt_mul ( atom_t  data2,
atom_t  data1 
)
Parameters:
data1first input
data2second input
Returns:
Number atom - product of it's arguments

Implements the primitive operator *.

{
atom_t rt_div ( atom_t  data2,
atom_t  data1 
)
Parameters:
data1first input
data2second input
Returns:
Number atom - quotient of it's arguments

Implements the primitive operator /.

{
atom_t rt_sum ( int  data)
Parameters:
datanumber of inputs of SUM
Returns:
Number atom - sum of all arguments

Implements the primitive SUM. The only input contains the number of inputs which are pulled out from the stack. Returns their sum

  {
    GET_FLOAT( ARGUMENT, x );
    acc += x;
  }
  RETURN( new_float( acc ) );
}


//===================================================
atom_t rt_difference ( atom_t  data2,
atom_t  data1 
)
Parameters:
data1first input
data2second input
Returns:
Number atom - difference of arguments

Implements the aritmetic primitive DIFFERENCE

{
Parameters:
dataargument
Returns:
Number atom - negate of the argument

Implements the aritmetic primitive MINUS

{
atom_t rt_product ( int  data)
Parameters:
datanumber of inputs of PRODUCT
Returns:
Number atom - product of all arguments

Implements the primitive PRODUCT. The only input contains the number of inputs which are pulled out from the stack. Returns their product

  {
    GET_FLOAT( ARGUMENT, x );
    acc *= x;
  }
  RETURN( new_float( acc ) );
}


//===================================================
atom_t rt_remainder ( atom_t  data2,
atom_t  data1 
)
Parameters:
data1first input
data2second input
Returns:
Integer number atom - remainder of devision data1 / data2

Implements the aritmetic primitive REMAINDER

  { RETURN( new_integer( x % y ) ); }
  else
  { RETURN( new_integer( 0 ) ); }
}


//===================================================
atom_t rt_int ( atom_t  data)
Parameters:
dataargument
Returns:
Integer number atom - integer part of argument

Implements the aritmetic primitive INT

{
atom_t rt_round ( atom_t  data)
Parameters:
dataargument
Returns:
Integer number atom - rounded integer nearest to argument

Implements the aritmetic primitive ROUND

{
atom_t rt_sqrt ( atom_t  data)
Parameters:
dataargument
Returns:
Number atom - square root of argument

Implements the aritmetic primitive SQRT Calculates square root from the number

{
atom_t rt_power ( atom_t  power,
atom_t  base 
)
Parameters:
basebase number
powerpower to calculate
Returns:
Number atom - base on power

Implements the aritmetic primitive POWER

{
atom_t rt_exp ( atom_t  power)
Parameters:
powerpower to calculate
Returns:
Number atom - e on power

Outputs e (2.718281828+) to the input power.

{
atom_t rt_log10 ( atom_t  data)
Parameters:
dataargument
Returns:
Number atom - logarithm of argument

Outputs the common logarithm of the input

{
atom_t rt_ln ( atom_t  data)
Parameters:
dataargument
Returns:
Number atom - natural logarithm of argument

Outputs natural logarithm of the input

{
atom_t rt_abs ( atom_t  data)
Parameters:
dataargument
Returns:
Number atom - absolute value of argument

Outputs the absolute value of the input

{
atom_t rt_pi ( void  )
Returns:
Number atom - PI number (3.141592...)

Outputs Value of PI

{
atom_t rt_sin ( atom_t  data)
Parameters:
dataargument in degrees
Returns:
Number atom - Sine of argument

Outputs the sine of its input, which is taken in degrees

  {
    x = 0;
  }
  else
  if (fabs( 0.5 + x ) < ZERO_PRECISION)
  {
    x = -0.5;
  }
  else
  if (fabs( 0.5 - x ) < ZERO_PRECISION)
  {
    x = 0.5;
  }
  else
  if (fabs( 1 + x ) < ZERO_PRECISION)
  {
    x = -1;
  }
  else
  if (fabs( 1 - x ) < ZERO_PRECISION)
  {
    x = 1;
  }

  RETURN( new_float( x ) );
}


//===================================================
atom_t rt_radsin ( atom_t  data)
Parameters:
dataargument in radians
Returns:
Number atom - Sine of argument

Outputs the sine of its input, which is taken in radians

  {
    x = 0;
  }
  RETURN( new_float( x ) );
}


//===================================================
atom_t rt_cos ( atom_t  data)
Parameters:
dataargument in degrees
Returns:
Number atom - Cosine of argument

Outputs the cosine of its input, which is taken in degrees

  {
    x = 0;
  }
  else
  if (fabs( 0.5 + x ) < ZERO_PRECISION)
  {
    x = -0.5;
  }
  else
  if (fabs( 0.5 - x ) < ZERO_PRECISION)
  {
    x = 0.5;
  }
  else
  if (fabs( 1 + x ) < ZERO_PRECISION)
  {
    x = -1;
  }
  else
  if (fabs( 1 - x ) < ZERO_PRECISION)
  {
    x = 1;
  }

  RETURN( new_float( x ) );
}


//===================================================
atom_t rt_radcos ( atom_t  data)
Parameters:
dataargument in radians
Returns:
Number atom - Cosine of argument

Outputs the cosine of its input, which is taken in radians

  {
    x = 0;
  }

  RETURN( new_float( x ) );
}


//===================================================
atom_t rt_arctan ( int  count,
atom_t  data2,
atom_t  data1 
)
Parameters:
countnumber of arguments (1 or 2)
data1first argument
data2second argument
Returns:
Number atom - Arctangent of argument(s)

Outputs the arctangent, in degrees, of its input.

  {
    x = atan( y );
  }
  else
  {
    GET_FLOAT( data1, x );
    x = atan2( x, y );
  }

  //Convert radians to degrees.
  x = (x * 180) / M_PI;
  RETURN( new_float( x ) );
}


//===================================================
atom_t rt_radarctan ( int  count,
atom_t  data2,
atom_t  data1 
)
Parameters:
countnumber of arguments (1 or 2)
data1first argument
data2second argument
Returns:
Number atom - Arctangent of argument(s)

Outputs the arctangent, in radians, of its input.

  {
    x = atan( y );
  }
  else
  {
    GET_FLOAT( data1, x );
    x = atan2( x, y );
  }

  RETURN( new_float( x ) );
}


//===================================================
atom_t rt_make ( int  static_link,
atom_t  parent,
atom_t  value,
atom_t  name 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
namename of variable
valuenew value of variable

Implements the primitive command MAKE. This function is called when it is not possible to compile MAKE. This happens when the name of the variable is an expression or is unknown. In such cases the search for the variable must be done in run-time.

  {
    var = new_var( word, globals, 1 );
    SET_FLAGS( var, FLAG_VARIABLE );
    VARTYPE( var ) = VAR_TYPE_RUNTIME;
    VALUE( var ) = USE( unbound );
  }

  // var name as a word is not needed any more
  DEUSE( word );

  // not a variable (i.e. it is a function or a procedure)
  if (!IS_VARIABLE( var ))
  RETURN( new_error( ERROR_NOT_A_VAR, name ) );

  //printf("rt_make, var="); dumpln(var);
  //printf("rt_make, val="); dumpln(value);
  rt_set_var_value( static_link, parent, var, value );
  //printf("value is set, see var(%x)=",(int)var); dumpln(var);
  //printf("        its parent is="); dumpln(PARENT(var));
  RETURN( unbound );
}




//===================================================
atom_t rt_name ( int  static_link,
atom_t  parent,
atom_t  name,
atom_t  value 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
namename of variable
valuenew value of variable

Implements the primitive command NAME. It uses the same code as MAKE.

{
atom_t rt_local ( int  static_link,
atom_t  parent,
int  data 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
datacount of LOCAL's arguments

Implements the primitive command LOCAL. LOCAL is processed by the parser, so this function is not called.

  {
    //printf("creating local var: "); dumpln(ARGUMENT);
    if (IS_ERROR( ARGUMENT )) RETURN( USE( ARGUMENT ) );
    if (IS_UNBOUND( ARGUMENT ))
    {
      return new_error( ERROR_MISSING_VALUE, unbound );
    }

    // check whether this variable exists locally
    if (find_local_var( ARGUMENT, parent ) ||
        find_local_var( ARGUMENT, *localsp ))
    {
      return new_error( ERROR_DUPLICATE_INPUT, ARGUMENT );
    }

    atom_t var = new_var( ARGUMENT, parent, 0 );
    SET_FLAGS( var, FLAG_VARIABLE );
    VALUE( var ) = USE( unbound );
    VARTYPE( var ) = VAR_TYPE_RUNTIME;
    *localsp = new_list( var, *localsp ); // attach to other runtimers
  };
  //printf("new locals="); dumpln(*localsp);
  RETURN( unbound );
}


//===================================================
int num_compare ( float64_t  x,
float64_t  y 
)
Parameters:
xfirst number
ysecond number
Returns:
Compatison result

Compares two numbers. If first is larger returns positive number, if first is smaller returns negative number, if both are equal returns 0

{
int word_compare ( int  cip,
chars_t  w1,
int  w1_len,
chars_t  w2,
int  w2_len 
)
Parameters:
cipto ignote or not case in comparison
w1first word
w1_lenfirst word length
w2second word
w2_lensecond word length
Returns:
Compatison result

Compares two numbers. If first is larger returns positive number, if first is smaller returns negative number, if both are equal returns 0

  {
    while (w1_len && w2_len)
    {
      if (TOLOWER( DEBAR( w1[0] ) ) != TOLOWER( DEBAR( w2[0] ) ))
      return TOLOWER( DEBAR( w1[0] ) ) - TOLOWER( DEBAR( w2[0] ) );
      ++w1;
      ++w2;
      --w1_len;
      --w2_len;
    }
  }
  return w1_len - w2_len;
}


// Function prototype
int atom_equal( atom_t cip, atom_t data2, atom_t data1 );

//===================================================
int atom_equal ( atom_t  cip,
atom_t  data1,
atom_t  data2 
)
Parameters:
cipvalue of CASEIGNOREDP
data1first atom
data2second atom
Returns:
!= 0 number if lists are equal or 0 if they are not

Compares two atoms. if both are same types and have equal values returns positive number Returns 0 if atoms are diferent. Returns -1 if some error occurs

  {
    return 0;
  }

  // Now we know that both are lists or both are not lists
  if (IS_LIST( data1 ))
  {
    return list_equal( cip, data1, data2 );
  }

  if (!atom_to_boolean( cip, &case_ignore ))
  {
    case_ignore = 1;
  }

  // If both atoms are words - best way to compare them is directly
  if (IS_ANY_WORD( data1 ) && IS_ANY_WORD( data2 ))
  {
    int xx = word_compare( case_ignore, STRING( data1 ), LENGTH( data1 ), STRING( data2 ), LENGTH( data2 ) ) == 0;
    return xx;
  }

  // Here we are in case that both are numbers or unsupported types
  if (atom_to_float( data1, &x ))
  {
    // First is a number
    float64_t y;
    if (!atom_to_float( data2, &y ))
    {
      return 0;
    }
    return num_compare( x, y ) == 0; // Both are numbers
  }

  return -1; //Different or unsupproted atom types -> error
}



//===================================================
list_equal ( atom_t  cip,
atom_t  data1,
atom_t  data2 
)
Parameters:
cipvalue of CASEIGNOREDP
data1first list
data2second list
Returns:
!= 0 number if lists are equal or 0 if they are not

Compares two lists. if both are equal returns not 0 number Returns 0 if lists are diferent.

    {
      return comp;
    }

    data1 = CDR( data1 );
    data2 = CDR( data2 );
  }
  return (IS_EMPTY( data1 ) && IS_EMPTY( data2 ));
}


//===================================================
atom_t rt_equal ( atom_t  cip,
atom_t  data2,
atom_t  data1 
)
Parameters:
cipvalue of CASEIGNOREDP
data1first input
data2second input
Returns:
Boolean atom

Implements compare operation EQUALP

  {
    RETURN( new_error( ERROR_MISSING_VALUE, data2 ) );
  }

  RETURN( USE( false_true[comp > 0] ) );
}


//===================================================
atom_t rt_nequal ( atom_t  cip,
atom_t  data2,
atom_t  data1 
)
Parameters:
cipvalue of CASEIGNOREDP
data1first input
data2second input
Returns:
Boolean atom

Implements compare operation NOTEQUALP

  {
    RETURN( new_error( ERROR_MISSING_VALUE, data2 ) );
  }

  RETURN( USE( false_true[comp == 0] ) );
}


//===================================================
atom_t rt_less ( atom_t  data2,
atom_t  data1 
)
Parameters:
data1first number
data2second number
Returns:
Boolean atom

Implements compare operation LESSP Arguments must be numbers

{
atom_t rt_more ( atom_t  data2,
atom_t  data1 
)
Parameters:
data1first number
data2second number
Returns:
Boolean atom

Implements compare operation GREATERP Arguments must be numbers

{
atom_t rt_lesseq ( atom_t  data2,
atom_t  data1 
)
Parameters:
data1first number
data2second number
Returns:
Boolean atom

Implements compare operation LESSEQUALP Arguments must be numbers

{
atom_t rt_moreeq ( atom_t  data2,
atom_t  data1 
)
Parameters:
data1first number
data2second number
Returns:
Boolean atom

Implements compare operation GREATEREQUALP Arguments must be numbers

{
atom_t rt_before ( atom_t  cip,
atom_t  data2,
atom_t  data1 
)
Parameters:
cipvalue of CASEIGNOREDP
data1first word
data2second word
Returns:
Boolean atom

Implements compare operation BEFOREP Arguments must be words. Note that if the inputs are numbers, the result may not be the same as with LESSP; for example, BEFOREP 3 12 is false because 3 collates after 1.

  {
    word_x = STRING( data1 );
    len_x = LENGTH( data1 );
  }
  else if (atom_to_string( data1, x, &len_x ))
  {
    word_x = x;
  }
  else
  {
    RETURN( USE( false_true[0] ) );
  }

  if (IS_ANY_WORD( data2 ))
  {
    word_y = STRING( data2 );
    len_y = LENGTH( data2 );
  }
  else if (atom_to_string( data2, y, &len_y ))
  {
    word_y = y;
  }
  else
  {
    RETURN( USE( false_true[0] ) );
  }

  if (!atom_to_boolean( cip, &case_ignore ))
  {
    case_ignore = 1;
  }

  RETURN( USE( false_true[word_compare( case_ignore, word_x, len_x, word_y, len_y ) < 0] ) );
}



//===================================================
atom_t rt_output ( atom_t  data)
Parameters:
datareturn value of the Logo program
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for OUTPUT primitive.

{
Parameters:
datareturn value of the Logo program
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for MAYBEOUTPUT primitive.

{
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for STOP primitive.

{
atom_t rt_dump ( atom_t  source)
Parameters:
sourcesource of the command
Returns:
unbound atom

This function is used to dump the source of some comands (like OUTPUT).

{
atom_t rt_predump ( atom_t  source)
Parameters:
sourcesource of the command
Returns:
unbound atom

This function is used to predump the source of user-defined functions and commands. This is done in order to trace the function call before the tracing of function's block.

{
atom_t rt_and ( int  data)
Parameters:
datanumber of inputs of AND
Returns:
Boolean atom

Implements the primitive AND. The only input contains the number of inputs which are pulled out from the stack. Returns true if all are true false else.

    {
      RETURN( USE( false_true[0] ) );
    }
  }
  RETURN( USE( false_true[1] ) );
}


//===================================================
atom_t rt_or ( int  data)
Parameters:
datanumber of inputs of OR
Returns:
Boolean atom

Implements the primitive OR. The only input contains the number of inputs which are pulled out from the stack. Returns true if any is true false if all are false.

    {
      RETURN( USE( false_true[1] ) );
    }
  }
  RETURN( USE( false_true[0] ) );
}


//===================================================
atom_t rt_not ( atom_t  data)
Parameters:
databoolean argument
Returns:
Boolean atom

Outputs true is argument is false and false if argument is true

{
atom_t rt_ignore ( atom_t  data)
Parameters:
datavalue to ignore
Returns:
unbound atom

Implementation of the primitive command IGNORE. The value in data is ignored and the returned value is the unbound atom

  {
    RETURN( USE( unbound ) );
  }
}


//===================================================
atom_t rt_first ( atom_t  data)
Parameters:
dataword or list argument
Returns:
first element of input as atom

Outputs first letter of argument if it is word or first element of argument if it is list

  {
    if (IS_EMPTY( data ))
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }
    RETURN( USE( CAR( data ) ) );
  }
  if (IS_ANY_WORD( data ))
  {
    if (LENGTH( data ) == 0)
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }

    RETURN( new_subword( data, STRING( data ), 1 ) );
  }
  if (atom_to_string( data, buff, &buff_len ))
  {
    if (buff_len == 0)
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }

    RETURN( new_word( buff, 1 ) );
  }
  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
}


//===================================================
Parameters:
dataword or list argument
Returns:
all elements of input without first

If argument is word outputs word without first letter if argument is list outputs list without first element

  {
    if (IS_EMPTY( data ))
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }
    RETURN( USE( CDR( data ) ) );
  }
  if (IS_ANY_WORD( data ))
  {
    if (LENGTH( data ) == 0)
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }
    RETURN( new_subword( data, STRING( data ) + 1, LENGTH( data ) - 1 ) );
  }
  if (atom_to_string( data, buff, &buff_len ))
  {
    if (buff_len == 0)
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }

    RETURN( new_word( buff + 1, buff_len - 1 ) );
  }
  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
}


//===================================================
atom_t rt_firsts ( atom_t  data)
Parameters:
dataA list
Returns:
list of first element of each element of input list

Inserts in result first letter of element if it is word or first element of element if it is list

  {
    append( rt_first( CAR( data ) ), &result, &iter );
    data = CDR( data );
  }
  RETURN( result );
}

//===================================================
Parameters:
dataA list
Returns:
list of all elements of each element of data without first

If element is word inserts in result word without first letter; if element is list inserts in result the list without its first element

  {
    append( rt_butfirst( CAR( data ) ), &result, &iter );
    data = CDR( data );
  }
  RETURN( result );
}


//===================================================
atom_t rt_last ( atom_t  data)
Parameters:
dataword or list argument
Returns:
last element of input as atom

Outputs last letter of argument if it is word or last element of argument if it is list

  {
    if (IS_EMPTY( data ))
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }
    RETURN( USE( get_at_list( data, -1 ) ) );
  }
  if (IS_ANY_WORD( data ))
  {
    if (LENGTH( data ) == 0)
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }

    RETURN( new_subword( data, STRING( data ) + LENGTH( data ) - 1, 1 ) );
  }
  if (atom_to_string( data, buff, &buff_len ))
  {
    if (buff_len == 0)
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }

    RETURN( new_word( buff + buff_len - 1, 1 ) );
  }
  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
}


//===================================================
Parameters:
dataword or list argument
Returns:
all elements of input without last

If argument is word outputs word without last letter if argument is list outputs list without last element

  {
    if (IS_EMPTY( data ))
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }
    RETURN( list_copy_but_last( data ) );
  }
  if (IS_ANY_WORD( data ))
  {
    if (LENGTH( data ) == 0)
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }
    RETURN( new_subword( data, STRING( data ), LENGTH( data ) - 1 ) );
  }
  if (atom_to_string( data, buff, &buff_len ))
  {
    if (buff_len == 0)
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }

    RETURN( new_word( buff, buff_len - 1 ) );
  }
  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
}


//===================================================
atom_t rt_item ( atom_t  data,
atom_t  index 
)
Parameters:
dataword or list argument
indexinteger index of element to get
Returns:
The element at sepcified index

If argument is word outputs the char at position index if argument is list outputs the element at position index Indexing starts at 1 in both cases

  {
    RETURN( new_error( ERROR_NOT_A_NUMBER, index ) );
  }

  if (IS_LIST( data ))
  {
    if (IS_EMPTY( data ))
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }
    RETURN( USE( get_at_list( data, ind - 1 ) ) ); // -1 cause indexing starts from 1
  }
  if (IS_ANY_WORD( data ))
  {
    if (LENGTH( data ) < ind)
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }

    RETURN( new_subword( data, STRING( data ) + ind - 1, 1 ) );
  }
  if (atom_to_string( data, buff, &buff_len ))
  {
    if (buff_len < ind)
    {
      RETURN( new_error( ERROR_MISSING_VALUE, data ) );
    }

    RETURN( new_word( buff + ind - 1, 1 ) );
  }
  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
}




//===================================================
atom_t rt_if ( int  count)
Parameters:
countnumber of parameters
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for IF primitive.

{
atom_t rt_repeat ( atom_t  repcount,
atom_t  commands 
)
Parameters:
repcountnumber of repetitions
commandscommands to repeat
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for REPEAT primitive.

{
atom_t rt_while ( atom_t  commands,
atom_t  condition 
)

dummy implementation of primitive command DO.WHILE

Parameters:
conditionrepetition condition
commandscommands to repeat
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for WHILE primitive.

Parameters:
commandscommands to repeat
conditionrepetition condition
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for DO.WHILE primitive.

{
atom_t rt_dowhile ( atom_t  commands,
atom_t  condition 
)
{
atom_t rt_until ( atom_t  condition,
atom_t  commands 
)
Parameters:
conditionrepetition condition
commandscommands to repeat
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for UNTIL primitive.

{
atom_t rt_dountil ( atom_t  commands,
atom_t  condition 
)
Parameters:
commandscommands to repeat
conditionrepetition condition
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for DO.UNTIL primitive.

{
atom_t rt_whlchk ( atom_t  source,
atom_t  data 
)
Parameters:
datavalue to check
sourcesource of the expression
Returns:
error or unbound atom

Checks whether the condition of a while command is valid. Returns error atom is the result is error, or not boolean. Otherwise returns integer atoms containing 0 if the condition is false, and 1 otherwise. The source parameter points to the source where the expression is called. It is used to locate the error position in case of errors.

  {
    DEUSE( data );
    return new_error( ERROR_MISSING_VALUE, source );
  }

  int b;
  if (!atom_to_boolean( data, &b ))
  {
    DEUSE( data );
    return new_error( ERROR_BOOLEAN_EXPECTED, source );
  }

  DEUSE( data );

  return new_integer( b );
}




//===================================================
void rt_repeat_enter ( int  frame,
int  count 
)
Parameters:
framebase frame pointer
countnumber of requested repetitions

This function creates a new repeat node and inserts it in the beginning of the repeat chain. The repeat-node contains the number of repetitions done so far (REPCOUNT) and left to do (REPLIMIT). The base pointer is used to access the repeat chain.

  {
    // we create the first repeat-node
    DEUSE( *chain_ptr );
    *chain_ptr = new_list( node, empty_list );
  }
  else
  {
    // we add a new repeat-node
    *chain_ptr = new_list( node, *chain_ptr );
  }
}



//===================================================
atom_t rt_repeat_exit ( int  frame)
Parameters:
framebase frame pointer
Returns:
unbound atom

This function removes the top-most repeat-node and returns unbound atom.

  {
#ifdef SAFEMODE
    assert( IS_LIST( *chain_ptr ) );
#endif

    *chain_ptr = behead( *chain_ptr );

    if (IS_EMPTY( *chain_ptr ))
    *chain_ptr = USE( unbound );
  }

  //printf("exitus repeatus\n");
  RETURN( unbound );
}



//===================================================
atom_t rt_repcount ( int  frame)
Parameters:
framebase frame pointer
Returns:
numeric atom containing repcount value

Repetition count is always stored at the top of the stack, so the implementation of repcount naturally treats the top of the stack as its parameter.

{
atom_t rt_forever ( atom_t  commands)
Parameters:
commandscommands to repeat
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for FOREVER primitive.

{
void rt_forever_enter ( int  frame)
Parameters:
framebase frame pointer

This function creates a new repeat node and inserts it in the beginning of the repeat chain. The repeat-node contains the number of repetitions done so far (REPCOUNT). The limit of repetitions (REPLIMIT) is set to 1, although this value is not used.

The base pointer is used to access the repeat chain.

  {
    // we create the first repeat-node
    DEUSE( *chain_ptr );
    *chain_ptr = new_list( node, empty_list );
  }
  else
  {
    // we add a new repeat-node
    *chain_ptr = new_list( node, *chain_ptr );
  }
}



//===================================================
atom_t rt_parse ( atom_t  data)
Parameters:
datadata to parse
Returns:
parsed data

Implements primitive function PARSE. Returns the input parsed as data.

{
Parameters:
datadata to parse
Returns:
parsed data

Implements primitive function RUNPARSE. Returns the input parsed as commands.

{
atom_t rt_wordp ( atom_t  data)
Parameters:
datadata to test
Returns:
true if data is word or false if is not

Implements primitive predicate WORDP. Returns true if argument is any word or false if it is not

  {
    char_t buff[MAX_NUMBER_WORD_LENGTH];
    int buff_len = MAX_NUMBER_WORD_LENGTH;

    if (atom_to_string( data, buff, &buff_len ))
    {
      RETURN( USE( false_true[1] ) );
    }
  }
  RETURN( USE( false_true[0] ) );
}


//===================================================
atom_t rt_listp ( atom_t  data)
Parameters:
datadata to test
Returns:
true if data is list or false if is not

Implements primitive predicate LISTP. Returns true if argument is list or false if it is not

{
Parameters:
datadata to test
Returns:
true if data is number or false if is not

Implements primitive predicate NUMBERP. Returns true if argument is any number or false if it is not

  {
    RETURN( USE( false_true[1] ) );
  }

  // Not a number
  RETURN( USE( false_true[0] ) );
}


//===================================================
atom_t rt_empty ( atom_t  data)
Parameters:
datadata to test
Returns:
true if data is empty or false if is not

Implements primitive predicate EMPTYP. Outputs true if argument is empty list or empty word. Outputs false if it is not.

  {
    RETURN( USE( false_true[1] ) );
  }

  // Not a list or empty word
  RETURN( USE( false_true[0] ) );
}


//===================================================
atom_t rt_memberp ( atom_t  cip,
atom_t  data,
atom_t  elem 
)
Parameters:
cipvalue of CASEIGNOREDP
dataData where will search
elemElement which will be searched
Returns:
true if elem is in data or false if is not

Implements primitive predicate MEMBERP. If data is list outputs true if data contains elem as an element and false if not If data is a word outputs true if elem is char that is contained in the word data

  {
    char_t buff[MAX_NUMBER_WORD_LENGTH];
    chars_t comp_buffer;
    int buff_len = MAX_NUMBER_WORD_LENGTH; // We start with 3 symbols. Actually need 1, but test if there is more
    char_t elem_ch;

    // If data is not a list, elem must be one character word
    if (IS_ANY_WORD( elem ) && LENGTH( elem ) != 1)
    {
      RETURN( USE( false_true[0] ) );
    }
    if (!IS_ANY_WORD( elem ) && (!atom_to_string( elem, buff, &buff_len ) || buff_len != 1))
    {
      RETURN( USE( false_true[0] ) );
    }

    if (buff_len == 1) // elem is one char word -> Store it
    {
      elem_ch = DEBAR( buff[0] );
    }
    else
    {
      elem_ch = DEBAR( STRING( elem )[0] );
    }

    if (IS_ANY_WORD( data ))
    {
      comp_buffer = STRING( data );
      buff_len = LENGTH( data );
    }
    else
    {
      buff_len = MAX_NUMBER_WORD_LENGTH;
      if (!atom_to_string( data, buff, &buff_len ) || buff_len == 0)
      {
        RETURN( USE( false_true[0] ) ); // data is not a word or empty
      }
      comp_buffer = buff;
    }
    while (buff_len--)
    {
      if (DEBAR( comp_buffer[buff_len] ) == elem_ch)
      {
        RETURN( USE( false_true[1] ) );
      }
    }
    RETURN( USE( false_true[0] ) );
  }
}


//===================================================
atom_t rt_word ( int  data)
Parameters:
datanumber of inputs of WORD
Returns:
New word concatenation of arguments

Implements the primitive WORD. The only input contains the number of inputs which are pulled out from the stack. Returns new word whish is concatenation of all arguments. All arguments must be words.

  {
    //printf("=======arg="); dumpln(ARGUMENT);
    if (IS_ERROR( ARGUMENT ))
    {
      RETURN( USE(ARGUMENT) );
    }

    if (IS_ANY_WORD( ARGUMENT ))
    {
      total_length += LENGTH( ARGUMENT );
    }
    else
    {
      // Assume data can be translated to string.
      total_length += MAX_NUMBER_WORD_LENGTH;
    }
  }

  // Allocate memory
  res = create_word( total_length );

  // And copy elements one by one
  for (EACH_ARGUMENT)
  {
    if (IS_ANY_WORD( ARGUMENT ))
    {
      STRNCPY( STRING( res ) + real_length, STRING( ARGUMENT ), LENGTH( ARGUMENT ) );
      real_length += LENGTH( ARGUMENT );
    }
    else
    {
      buff_len = MAX_NUMBER_WORD_LENGTH;
      if (!atom_to_string( ARGUMENT, buff, &buff_len ))
      {
        DEUSE( res );
        RETURN( new_error( ERROR_NOT_A_WORD, ARGUMENT ) );
      }

      STRNCPY( STRING( res ) + real_length, buff, buff_len );
      real_length += buff_len;
    }
  }

  // If allocated more memory than needed reallocate to free unused
  if (real_length != total_length)
  {
    STRING( res ) = REALLOC( STRING( res ), (real_length + 1) * sizeof (char_t) );
    IDLENGTH( res ) = WORD_ID | (real_length << 8);
  }

  STRING( res )[real_length] = NULL_CHAR;
  RETURN( res );
}


//===================================================
atom_t rt_list ( int  data)
Parameters:
datanumber of inputs of LIST
Returns:
New list containing all arguments

Implements the primitive LIST. The only input contains the number of inputs which are pulled out from the stack. Returns new list with elements all arguments passed to the function.

  {
    if (IS_ERROR( ARGUMENT ))
    {
      RETURN( USE(ARGUMENT) );
    }
  }

  for (EACH_ARGUMENT)
  {
    append( USE( ARGUMENT ), &res, &iter );
  }

  RETURN( res );
}


//===================================================
atom_t rt_sent ( int  data)
Parameters:
datanumber of inputs of SE
Returns:
New list containing all arguments

Implements the primitive SE. The only input contains the number of inputs which are pulled out from the stack. Returns new list with elements all arguments passed to the function if they are not lists. If an argument is list its members are added to result

  {
    if (IS_ERROR( ARGUMENT ))
    {
      RETURN( USE(ARGUMENT) );
    }
  }

  for (EACH_ARGUMENT)
  {
    if (IS_LIST( ARGUMENT ))
    {
      atom_t curr = ARGUMENT;

      while (IS_NOT_EMPTY( curr ))
      {
        test_elem_and_destroy_if_error( curr, res );
        append( USE( CAR( curr ) ), &res, &iter );
        curr = CDR( curr );
      }
    }
    else
    {
      append( USE( ARGUMENT ), &res, &iter );
    }
  }

  RETURN( res );
}


//===================================================
atom_t rt_fput ( atom_t  data2,
atom_t  data1 
)
Parameters:
data1Element to add
data2List or word
Returns:
New list or word containing data2 with data1 at start

Implements the primitive FPUT. Returns data2 with data1 inserted at first position. If data2 is a word, data1 must be one char word.

  {
    char_t buff2[MAX_NUMBER_WORD_LENGTH];
    int buff_len2 = MAX_NUMBER_WORD_LENGTH;

    char_t buff1[MAX_NUMBER_WORD_LENGTH];
    int buff_len1 = MAX_NUMBER_WORD_LENGTH;

    atom_t res;

    /* check parametr correctness */
    if (!IS_ANY_WORD( data2 ) && !atom_to_string( data2, buff2, &buff_len2 ))
    {
      RETURN( new_error( ERROR_NOT_A_WORD, data2 ) );
    }

    if ((IS_ANY_WORD( data1 ) && LENGTH( data1 ) != 1) ||
        (!atom_to_string( data1, buff1, &buff_len1 ) || buff_len1 != 1))
    {
      RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data1 ) );
    }

    if (IS_ANY_WORD( data2 ))
    {
      res = create_word( 1 + LENGTH( data2 ) );
      STRING( res )[0] = IS_ANY_WORD( data1 ) ? STRING( data1 )[0] : buff1[0];
      STRNCPY( STRING( res ) + 1, STRING( data2 ), LENGTH( data2 ) );
    }
    else
    {
      res = create_word( 1 + buff_len2 );
      STRING( res )[0] = IS_ANY_WORD( data1 ) ? STRING( data1 )[0] : buff1[0];
      STRNCPY( STRING( res ) + 1, buff2, buff_len2 );
    }

    STRING( res )[LENGTH( res )] = NULL_CHAR;
    RETURN( res );
  }
}


//===================================================
atom_t rt_lput ( atom_t  data2,
atom_t  data1 
)
Parameters:
data1Element to add
data2List or word
Returns:
New list or word containing data2 with data1 at end

Implements the primitive LPUT. Returns data2 with data1 appended to last position. If data2 is a word, data1 must be one char word.

  {
    char_t buff2[MAX_NUMBER_WORD_LENGTH];
    int buff_len2 = MAX_NUMBER_WORD_LENGTH;

    char_t buff1[MAX_NUMBER_WORD_LENGTH];
    int buff_len1 = MAX_NUMBER_WORD_LENGTH;

    atom_t res;

    /* check parametr correctness */
    if (!IS_ANY_WORD( data2 ) && !atom_to_string( data2, buff2, &buff_len2 ))
    {
      RETURN( new_error( ERROR_NOT_A_WORD, data2 ) );
    }

    if ((IS_ANY_WORD( data1 ) && LENGTH( data1 ) != 1) ||
        (!atom_to_string( data1, buff1, &buff_len1 ) || buff_len1 != 1))
    {
      RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data1 ) );
    }

    if (IS_ANY_WORD( data2 ))
    {
      res = create_word( 1 + LENGTH( data2 ) );
      STRNCPY( STRING( res ), STRING( data2 ), LENGTH( data2 ) );
      STRING( res )[LENGTH( data2 )] = IS_ANY_WORD( data1 ) ? STRING( data1 )[0] : buff1[0];
    }
    else
    {
      res = create_word( 1 + buff_len2 );
      STRNCPY( STRING( res ), buff2, buff_len2 );
      STRING( res )[buff_len2] = IS_ANY_WORD( data1 ) ? STRING( data1 )[0] : buff1[0];
    }

    STRING( res )[LENGTH( res )] = NULL_CHAR;
    RETURN( res );
  }
}


//===================================================
atom_t rt_count ( atom_t  data)
Parameters:
dataAtom to inspect
Returns:
Number of elements in data

Implements the primitive COUNT. Returns number of chars in data if data is word or number of elements in data if data is list

  {
    RETURN( new_integer( LENGTH( data ) ) );
  }
  if (IS_LIST( data ))
  {
    RETURN( new_integer( list_length( data ) ) );
  }
  if (atom_to_string( data, buff, &buff_len ))
  {
    RETURN( new_integer( buff_len ) );
  }
  RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data ) );
}


//===================================================
atom_t rt_char ( atom_t  data)
Parameters:
dataASCII code
Returns:
Char coresponding to data

Implements the primitive CHAR. Returns one char word containing symbol with given ASCII code

  {
    if (x < 0 || x > ((1 << 16) - 1))
    {
      RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data ) );
    }
    str[0] = (char_t) x;
    str[1] = NULL_CHAR;
    RETURN( new_word( str, 1 ) );
  }
#endif

  if (x < 0 || x > 255)
  {
    RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data ) );
  }

  str[0] = DEBAR( (char_t) x );
  str[1] = NULL_CHAR;
  RETURN( new_word( str, 1 ) );
}



//===================================================
atom_t rt_ascii ( atom_t  data)
Parameters:
dataone char word
Returns:
ASCII code of data

Implements the primitive ASCII. Returns ASCII code of given char

  {
    if (LENGTH( data ) != 1)
    {
      RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data ) );
    }
#ifdef UNICODE_CHARS
    if (!OPTION_TRADITIONAL)
    {
      RETURN( new_integer( (ushort_t) DEBAR( STRING( data )[0] ) ) );
    }
#endif
    RETURN( new_integer( (byte_t) DEBAR( STRING( data )[0] ) ) );
  }

  if (IS_LIST( data ))
  {
    RETURN( new_error( ERROR_NOT_A_WORD, data ) );
  }

  if (atom_to_string( data, buff, &buff_len ))
  {
    if (buff_len == 1)
    {
#ifdef UNICODE_CHARS
      if (!OPTION_TRADITIONAL)
      {
        RETURN( new_integer( (ushort_t) DEBAR( buff[0] ) ) );
      }
#endif
      RETURN( new_integer( (byte_t) DEBAR( buff[0] ) ) );
    }

    // Word but too long
    RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data ) );
  }
  RETURN( new_error( ERROR_NOT_A_WORD, data ) );
}



//===================================================
atom_t rt_lower ( atom_t  data)
Parameters:
dataword
Returns:
New word all in lowercase letters

Implements the primitive LOWERCASE. Returns word produced from data with replacing all uppercase letters with lowercase letters

  {
    res = new_word( STRING( data ), LENGTH( data ) );
  }
  else
  {
    char_t buff[MAX_NUMBER_WORD_LENGTH];
    int buff_len = MAX_NUMBER_WORD_LENGTH;

    if (IS_LIST( data ) || !atom_to_string( data, buff, &buff_len ))
    {
      RETURN( new_error( ERROR_NOT_A_WORD, data ) );
    }
    // in case of boolean of scientific float mey be necessery to convert
    res = new_word( buff, buff_len );
  }

  // proces word and make convertion
  for (i = 0; i < LENGTH( res ); ++i)
  {
    STRING( res )[i] = TOLOWER( DEBAR( STRING( res )[i] ) );
  }

  RETURN( res );
}


//===================================================
atom_t rt_upper ( atom_t  data)
Parameters:
dataword
Returns:
New word all in lowercase letters

Implements the primitive UPPERCASE. Returns word produced from data with replacing all lowercase letters with uppercase letters

  {
    res = new_word( STRING( data ), LENGTH( data ) );
  }
  else
  {
    char_t buff[MAX_NUMBER_WORD_LENGTH];
    int buff_len = MAX_NUMBER_WORD_LENGTH;

    if (IS_LIST( data ) || !atom_to_string( data, buff, &buff_len ))
    {
      RETURN( new_error( ERROR_NOT_A_WORD, data ) );
    }
    // in case of boolean of scientific float mey be necessery to convert
    res = new_word( buff, buff_len );
  }

  // proces word and make convertion
  for (i = 0; i < LENGTH( res ); ++i)
  {
    STRING( res )[i] = TOUPPER( DEBAR( STRING( res )[i] ) );
  }

  RETURN( res );
}


//===================================================
atom_t rt_member ( atom_t  cip,
atom_t  elem,
atom_t  data 
)
Parameters:
cipvalue of CASEIGNOREDP
dataData where will search
elemElement which will be searched
Returns:
Elements of data form first occurence of elem to the end

Implements primitive predicate MEMBER. If data is list outputs list containing all elements of data after first occurence of elem or empty list if elem is not a member of data If data is a word outputs subword of data starting from first occurence of elem to the end or empty word if elem is not a member of data

  { // Test all elements of the list for equality with elem
    while (!IS_EMPTY( data ))
    {
      if (atom_equal( cip, CAR( data ), elem ))
      RETURN( USE( data ) );
      data = CDR( data );
    }
    RETURN( USE( empty_list ) );
  }
  else
  {
    char_t buff[MAX_NUMBER_WORD_LENGTH];
    chars_t comp_buffer;
    int buff_len = MAX_NUMBER_WORD_LENGTH; // We start with 3 symbols. Actually need 1, but test if there is more
    int pos;
    char_t elem_ch;

    // If data is not a list, elem must be one character word
    if (IS_ANY_WORD( elem ) && LENGTH( elem ) != 1)
    {
      RETURN( new_error( ERROR_INCOMPATIBLE_DATA, elem ) );
    }
    if (!IS_ANY_WORD( elem ) && (!atom_to_string( elem, buff, &buff_len ) || buff_len != 1))
    {
      RETURN( new_error( ERROR_INCOMPATIBLE_DATA, elem ) );
    }

    if (buff_len == 1) // elem is one char word -> Store it
    {
      elem_ch = DEBAR( buff[0] );
    }
    else
    {
      elem_ch = DEBAR( STRING( elem )[0] );
    }

    if (IS_ANY_WORD( data ))
    {
      comp_buffer = STRING( data );
      buff_len = LENGTH( data );
    }
    else
    {
      buff_len = MAX_NUMBER_WORD_LENGTH;
      if (!atom_to_string( data, buff, &buff_len ) || buff_len == 0)
      {
        RETURN( new_error( ERROR_NOT_A_WORD, data ) );
      }
      comp_buffer = buff;
    }
    pos = 0;
    while (pos < buff_len)
    {
      if (DEBAR( comp_buffer[pos] ) == elem_ch)
      {
        if (IS_ANY_WORD( data ))
        {
          RETURN( new_subword( data, comp_buffer + pos, buff_len - pos ) );
        }
        else
        {
          RETURN( new_word( comp_buffer + pos, buff_len - pos ) );
        }
      }
      ++pos;
    }
    RETURN( new_word( buff, 0 ) );
  }
}


//===================================================
atom_t rt_iseq ( atom_t  to,
atom_t  from 
)
Parameters:
fromFirst element of the sequence
toLast element of the sequence
Returns:
List form all elements between from and to

Implements primitive predicate ISEQ. Returns a list containing all numbers between from and to. Parameters must be integers.

  {
    for (; first >= last; --first)
    append( new_integer( first ), &list_start, &list_end );
  }
  else
  {
    for (; first <= last; ++first)
    append( new_integer( first ), &list_start, &list_end );
  }
  RETURN( list_start );
}


//===================================================
atom_t rt_rseq ( atom_t  count,
atom_t  to,
atom_t  from 
)
Parameters:
fromFirst element of the sequence
toLast element of the sequence
countNumber of elements in the sequence
Returns:
List form count elements between from and to

Implements primitive predicate RSEQ. Returns a list containing count numbers between from and to. All numbers are equally spaced rational.

  {
    RETURN( new_error( ERROR_INCOMPATIBLE_DATA, count ) );
  }

  list_start = list_end = empty_list;
  if (first > last)
  {
    for (step = cnt > 1 ? (first - last) / (cnt - 1) : 0; cnt > 0; --cnt, first -= step)
    {
      append( new_float( first ), &list_start, &list_end );
    }
  }
  else
  {
    for (step = cnt > 1 ? (last - first) / (cnt - 1) : 0; cnt > 0; --cnt, first += step)
    {
      append( new_float( first ), &list_start, &list_end );
    }
  }
  RETURN( list_start );
}


//===================================================
rt_random ( int  count,
atom_t  data2,
atom_t  data1 
)
Parameters:
countnumber of arguments (1 or 2)
data1first argument
data2second argument
Returns:
Random number.

Implements the primitive RANDOM If called with one arg outputs a nonnegative integer less than its input first. If input is a list outputs randomly selected element from it If called with two arguments outputs a nonnegative random integer greater than or equal to data1, and less than or equal to data2

      {
        RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data2 ) );
      }

      len = list_length( data2 );
      RETURN( USE( get_at_list( data2, rand_num % len ) ) );
    }
    else
    {
      int64_t num;
      GET_INT( data2, num );

      if (num <= 0)
      {
        RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data2 ) );
      }
      RETURN( new_integer( rand_num % num ) );
    }
  }
  else if (count == 2)
  {
    int64_t start;
    int64_t end;

    GET_INT( data1, start );
    GET_INT( data2, end );

    if (start > end || start < 0)
    {
      RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data1 ) );
    }
    RETURN( new_integer( rand_num % (end - start + 1) + start ) );
  }
  else
  {
    RETURN( new_error( ERROR_CROWDED_EXPRESSION, data1 ) );
  }
}


//===================================================
atom_t rt_rerandom ( int  count,
atom_t  seed 
)
Parameters:
countnumber of arguments (0 or 1)
seednumber to set random seed

Implements the primitive RERANDOM. Makes the results of RANDOM reproducible.

  {
    rseed = 0;
  }
  else
  {
    RETURN( new_error( ERROR_CROWDED_EXPRESSION, seed ) );
  }

  srand( (uint_t) rseed );
  RETURN( unbound );
}


//===================================================
atom_t rt_show ( atom_t  pdl,
atom_t  pwl,
atom_t  fpp,
int  data 
)
Parameters:
pdlvalue of PRINTDEPTHLIMIT
pwlvalue of PRINTWIDTHLIMIT
fppvalue of FULLPRINTP
datanumber of inputs of SHOW

Implements the primitive SHOW. The only input contains the number of inputs which are pulled out from the stack. Prints input like PRINT except that if an input is a list it is printed inside square brackets

  {
    if (IS_ERROR( ARGUMENT ))
    {
      RETURN( USE(ARGUMENT) );
    }

    // If list adds square brackets
    if (IS_LIST( ARGUMENT ))
    {
      outter( TEXT( "[" ), 1 );
      dump( ARGUMENT );
      outter( TEXT( "]" ), 1 );
    }
    else
    {
      dump( ARGUMENT );
    }
    outter( TEXT( " " ), 1 );
  }

  outter( TEXT( "\n" ), 1 );
  RETURN( unbound );
}


//===================================================
atom_t rt_type ( atom_t  pdl,
atom_t  pwl,
atom_t  fpp,
int  data 
)
Parameters:
pdlvalue of PRINTDEPTHLIMIT
pwlvalue of PRINTWIDTHLIMIT
fppvalue of FULLPRINTP
datanumber of inputs of TYPE

Implements the primitive TYPE. The only input contains the number of inputs which are pulled out from the stack. Prints input like PRINT except that no new line is printed at the end and no spaces is printed between inputs.

  {
    if (IS_ERROR( ARGUMENT ))
    {
      RETURN( USE(ARGUMENT) );
    }
    dump( ARGUMENT );
  }
  RETURN( unbound );
}


//===================================================
atom_t rt_form ( atom_t  precision,
atom_t  width,
atom_t  num 
)
Parameters:
numnumber to be converted
widthwidth in wich number will be printed
precisionprecision with wich number will be printed
Returns:
Word representing given num.

Implements the primitive FORM. Outputs string representation of num printed with precision digits after decimal point and in at least width chars If width is more than number length some spaces are inserted in front of the string to fill width chars

  {
    GET_INT( width, num_width );
    format = TEXT( "%*.*lf" );
    SPRINT( buff, buff_len, format, (uint_t) num_width, (uint_t) num_prec, number );
  }
  else
  {
    if (IS_ANY_WORD( width ))
    {
      format = STRING( width );
      SPRINTF( buff, buff_len, format, number );
    }
    else
    {
      RETURN( new_error( ERROR_NOT_A_WORD, width ) );
    }
  }

  buff_len = STRLEN( buff );
  RETURN( new_word( buff, buff_len ) );
}


//===================================================
char_t get_format ( chars_t  string)
Parameters:
stringa format string
Returns:
Format char.

Returns format char or 0 if no format is passed or more than one format specifiers occur.

    {
      ++elem;
      if (elem[0] == TEXT( '%' ))
      {
        elem += 1;
      }
      else
      {
        while (ISDIGIT( *elem ) || *elem == TEXT( '.' ))
        {
          ++elem;
        }
        while (*elem == TEXT( 'l' ) || *elem == TEXT( 'u' ) || *elem == TEXT( 'h' ))
        ++elem;
      }
      if (type) return 0;
      type = *elem;
    }
  }
  return type;
}


//===================================================
atom_t rt_format ( atom_t  format,
atom_t  data 
)
Parameters:
datadata to be formated
formatformating string
Returns:
Word representing given data according to format string.

Implements the primitive FORMAT. Outputs string representation of data according to format formating string using printf sintax

  {
    char_t buff[MAX_WORD_LENGTH];
    int buff_len = MAX_WORD_LENGTH;
    char_t end = STRING( format )[LENGTH( format )];

    STRING( format )[LENGTH( format )] = NULL_CHAR;
    char_t format_chr = get_format( STRING( format ) );

    switch (format_chr)
    {
      // Integer number
    case TEXT( 'd' ) : case TEXT( 'i' ) : case TEXT( 'u' ) :

    case TEXT( 'x' ) : case TEXT( 'X' ) : case TEXT( 'o' ) :
      {
        int64_t i_num;
        STRING( format )[LENGTH( format )] = end;
        GET_INT( data, i_num );
        STRING( format )[LENGTH( format )] = NULL_CHAR;
        SPRINTF( buff, buff_len, STRING( format ), i_num );
        break;
      }
      // Floating point number
    case TEXT( 'f' ) :
    case TEXT( 'e' ) : case TEXT( 'E' ) :
    case TEXT( 'g' ) : case TEXT( 'G' ) :

    case TEXT( 'a' ) : case TEXT( 'A' ) :
      {
        float64_t fl_num;
        STRING( format )[LENGTH( format )] = end;
        GET_FLOAT( data, fl_num );
        STRING( format )[LENGTH( format )] = NULL_CHAR;
        SPRINTF( buff, buff_len, STRING( format ), fl_num );
        break;
      }

      // char

    case TEXT( 'c' ) : case TEXT( 'C' ) :
      {
        char_t ch;
        if (IS_ANY_WORD( data ))
        {
          if (LENGTH( data ) == 0)
          {
            STRING( format )[LENGTH( format )] = end;
            RETURN( new_error( ERROR_MISSING_VALUE, data ) );
          }
          ch = STRING( data )[0];
        }
        else
        if (atom_to_string( data, buff, &buff_len ))
        {
          if (buff_len == 0)
          {
            STRING( format )[LENGTH( format )] = end;
            RETURN( new_error( ERROR_MISSING_VALUE, data ) );
          }
          ch = buff[0];
        }
        else
        {
          STRING( format )[LENGTH( format )] = end;
          RETURN( new_error( ERROR_NOT_A_WORD, data ) );
        }
        buff_len = MAX_WORD_LENGTH;
        SPRINTF( buff, buff_len, STRING( format ), ch );
        break;
      }

      // string

    case TEXT( 's' ) : case TEXT( 'S' ) :
      {
        if (IS_ANY_WORD( data ))
        {
          char_t term = STRING( data )[LENGTH( data )];
          STRING( data )[LENGTH( data )] = NULL_CHAR;
          SPRINTF( buff, buff_len, STRING( format ), STRING( data ) );
          STRING( data )[LENGTH( data )] = term;
        }
        else
        {
          char_t num_buff[MAX_NUMBER_WORD_LENGTH];
          int num_buff_len;

          if (atom_to_string( data, num_buff, &num_buff_len ))
          {
            SPRINTF( buff, buff_len, STRING( format ), num_buff );
          }
          else
          {
            STRING( format )[LENGTH( format )] = end;
            RETURN( new_error( ERROR_NOT_A_WORD, data ) );
          }
        }
        break;
      }
      // pointer

    case TEXT( 'p' ) :
      {
        SPRINTF( buff, buff_len, STRING( format ), data );
        break;
      }
    default:
      {
        STRING( format )[LENGTH( format )] = end;
        RETURN( new_error( ERROR_INCOMPATIBLE_DATA, format ) );
      }
    }

    STRING( format )[LENGTH( format )] = end;
    buff_len = STRLEN( buff );
    RETURN( new_word( buff, buff_len ) );
  }
}



//===================================================
atom_t rt_formattime ( atom_t  format,
atom_t  data 
)
Parameters:
datadata to be formated
formatformating string
Returns:
Word representing given data according to format string.

Implements the primitive FORMATTIME. Outputs string representation of data according to date/time format formating string using strftime sintax.

  {
    RETURN( new_error( ERROR_NOT_A_WORD, format ) );
  }

  int64_t time64;
  if( !atom_to_int( data, &time64 ) )
  {
    RETURN( new_error( ERROR_NOT_AN_INTEGER, data ) );
  }
  time_t time = time64;

  atom_t formatz = atom_to_real_word( format );

  struct tm *presult;
  presult = gmtime( &time );
  char_t buf[MAX_WORD_LENGTH];
  int len;
  if( presult )
    len = STRFTIME( buf, MAX_WORD_LENGTH, STRING(formatz), presult ); 
  else
    len = 0;
 
  res = new_word( buf, len );
  DEUSE( formatz );
  
  RETURN( res );
}



//===================================================
atom_t rt_definedp ( int  static_link,
atom_t  parent,
atom_t  data 
)
Parameters:
datadata to test
static_linkstatic link from the current frame
parentcurrent parent
Returns:
true if data contains the name of a user-defined function

Implements primitive predicate DEFINED?. Returns true if data contains the name of a user-defined function or command.

{
atom_t rt_primitivep ( int  static_link,
atom_t  parent,
atom_t  data 
)
Parameters:
datadata to test
static_linkstatic link from the current frame
parentcurrent parent
Returns:
true if data contains the name of a primitive function

Implements primitive predicate PRIMiTIVE?. Returns true if data contains the name of a primitive function or command.

{
atom_t rt_namep ( int  static_link,
atom_t  parent,
atom_t  data 
)
Parameters:
datadata to test
static_linkstatic link from the current frame
parentcurrent parent
Returns:
true if data contains the name of a variable

Implements primitive predicate NAME?. Returns true if data contains the name of a variable.

{
atom_t rt_procedurep ( int  static_link,
atom_t  parent,
atom_t  data 
)
Parameters:
datadata to test
static_linkstatic link from the current frame
parentcurrent parent
Returns:
true if data contains the name of a function or a command

Implements primitive predicate PROCEDURE?. Returns true if data contains the name of a function or a command.

{
atom_t rt_var_value ( int  static_link,
atom_t  parent,
atom_t  var 
)
Parameters:
varthe variable
static_linkstatic link from the current frame
parentcurrent parent
Returns:
the value of the variable

This function looks for the value of a variable, somewhere in a stack frame. If the variable is global do not scan the stack.

{
atom_t rt_use_var ( atom_t  source,
atom_t  value 
)
Parameters:
sourcethe source code
valuethe variable's value
Returns:
the value of the variable

This function increases the reference count of a variable's value and check whether it is acceptible for a value -- i.e. it is neither error or unbound.

{
atom_t rt_thing ( int  static_link,
atom_t  parent,
atom_t  data 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
datavariable name
Returns:
the value of variable with given name

Implements primitive THING. Returns the value of the variable which name is the value of data. If there is no variable, then return error atom.

{
atom_t rt_reference ( int  static_link,
atom_t  parent,
atom_t  data 
)
Parameters:
datavariable name
static_linkstatic link from the current frame
parentcurrent parent
Returns:
the value of variable with given name

Implements the : syntax. Returns the value of the variable which name is following the colons. If there is no variable, then return error atom.

  {
    //printf("var="); dumpln(var);
    RETURN( USE( VALUE( var ) ) );
  }

  //printf("value="); dumpln(VALUE(var));

  // user-defined variable
  RETURN( USE( rt_var_value( static_link, parent, var ) ) );
}


//===================================================

Implement command BYE Terminate the program

{
atom_t rt_wait ( atom_t  time)
Parameters:
timeTime to wait in 60-ths of second

Implement command WAIT Suspend the program execution for time 60-ths of second and flushes the output buffer.

  {
#ifdef WINDOWS
    wait_time = (wait_time * 1000) / 60; // convert 60-ths of second to milliseconds
    Sleep( wait_time );
#else
    wait_time = (wait_time * 1000 * 1000) / 60; // convert 60-ths of second to milliseconds
    usleep( wait_time );
#endif
  }
  RETURN( unbound );
}


//===================================================
atom_t rt_ashift ( atom_t  bits,
atom_t  num 
)
Parameters:
bitsNumber of bits to shift
numNumber to be shifted
Returns:
result of num << bits.

Implement logical operation ASHIFT. num is shifted bits bits to the left. if bits is negative the shift is to the right with sign bit fill

  {
    RETURN( new_integer( number >> -bits_num ) );
  }
  else
  {
    RETURN( new_integer( number << bits_num ) );
  }
}


//===================================================
atom_t rt_lshift ( atom_t  bits,
atom_t  num 
)
Parameters:
bitsNumber of bits to shift
numNumber to be shifted
Returns:
result of num << bits.

Implement logical operation LSHIFT. num is shifted bits bits to the left. if bits is negative the shift is to the right with zero bits fill

  {
    RETURN( new_integer( (int64_t) (((uint64_t) number) >> -bits_num) ) );
  }
  else
  {
    RETURN( new_integer( number << bits_num ) );
  }
}


//===================================================
atom_t rt_bitand ( int  data)
Parameters:
datanumber of inputs of BITAND
Returns:
binary AND of all arguments

Implement binary operation BITAND. The only input contains the number of inputs which are pulled out from the stack. Returns their binary product (AND)

  {
    GET_INT( ARGUMENT, x );
    acc &= x;
  }
  RETURN( new_integer( acc ) );
}


//===================================================
atom_t rt_bitor ( int  data)
Parameters:
datanumber of inputs of BITOR
Returns:
binary OR of all arguments

Implement binary operation BITOR. The only input contains the number of inputs which are pulled out from the stack. Returns their binary sum (OR)

  {
    GET_INT( ARGUMENT, x );
    acc |= x;
  }
  RETURN( new_integer( acc ) );
}



//===================================================
atom_t rt_bitxor ( int  data)
Parameters:
datanumber of inputs of BITXOR
Returns:
binary XOR of all arguments

Implement binary operation BITXOR. The only input contains the number of inputs which are pulled out from the stack. Returns their binary sum by modulo 2(XOR)

  {
    GET_INT( ARGUMENT, x );
    acc ^= x;
  }
  RETURN( new_integer( acc ) );
}


//===================================================
atom_t rt_bitnot ( atom_t  data)
Parameters:
datainteger number.
Returns:
binary NOT of the argument

Implement binary operation BITNOT. The only input contains the number to be negated. Returns its binary negation (NOT)

{
atom_t rt_pick ( atom_t  list)
Parameters:
lista list
Returns:
randomly selected element of list

Implement primitiwe function PICK. Returns randomly selected element of list

  {
    int len;
    int rand_num;
    if (IS_EMPTY( list ))
    {
      RETURN( new_error( ERROR_INCOMPATIBLE_DATA, list ) );
    }
    rand_num = rand( );
    len = list_length( list );
    RETURN( USE( get_at_list( list, rand_num % len ) ) );
  }
  RETURN( new_error( ERROR_NOT_A_LIST, list ) );
}


//===================================================
atom_t rt_remdup ( atom_t  cip,
atom_t  data 
)
Parameters:
cipvalue of CASEIGNOREDP
dataa list or a word
Returns:
the list without duplicate elements

Implement primitiwe function REMDUP. Remove all duplicate elements of its input. The element which remain is rightmost.

  {
    atom_t iter;
    atom_t res_iter;

    result = empty_list;
    res_iter = result;

    while (!IS_EMPTY(data))
    {
      iter = CDR(data);
      while (!IS_EMPTY(iter))
      {
        if (atom_equal( cip, CAR(data), CAR( iter ) ))
        {
          break;
        }
        iter = CDR( iter );
      }
      if (IS_EMPTY( iter ))
      {
        if (IS_EMPTY( res_iter ))
        {
          result = res_iter = new_list( USE( CAR(data) ), empty_list );
        }
        else
        {
          CDR( res_iter ) = new_list( USE( CAR(data) ), empty_list );
          res_iter = CDR( res_iter );
        }
      }
      data = CDR(data);
    }
  }
  else // Data is a WORD
  {
    size_t len, total;
    size_t i, j;
    int case_ignore;
    chars_t word;
    atom_t data1;
    if (!atom_to_boolean( cip, &case_ignore ))
    {
      case_ignore = 1;
    }
    data1 = atom_to_word(data);
    if (IS_ERROR(data1))
    {
      RETURN(data1);
    }

    total = len = LENGTH(data1);
    word = STRING(data1);
    if (case_ignore)
    {
      for (i = 0; i < total-1; ++i)
      {
        for (j = i+1; j < total; ++j)
        {
          if (TOLOWER(DEBAR(word[i]))==TOLOWER(DEBAR(word[j])))
          {
            --len;
            break;
          }
        }
      }
      result = create_word(len);
      len = 0;
      for (i = 0; i < total; ++i)
      {
        for (j = i+1; j < total; ++j)
        {
          if (TOLOWER(DEBAR(word[i]))==TOLOWER(DEBAR(word[j])))
          {
            break;
          }
        }
        if (j >= total)
        {
          STRING(result)[len++] = word[i];
        }
      }
    }
    else
    {
      for (i = 0; i < total-1; ++i)
      {
        for (j = i+1; j < total; ++j)
        {
          if (DEBAR(word[i])==DEBAR(word[j]))
          {
            --len;
            break;
          }
        }
      }
      result = create_word(len);
      len = 0;
      for (i = 0; i < total; ++i)
      {
        for (j = i+1; j < total; ++j)
        {
          if (DEBAR(word[i])==DEBAR(word[j]))
          {
            break;
          }
        }
        if (j >= total)
        {
          STRING(result)[len++] = word[i];
        }
      }
    }
    DEUSE(data1);
  }
  RETURN(result);
}


//===================================================
atom_t rt_remove ( atom_t  cip,
atom_t  data,
atom_t  elem 
)
Parameters:
cipvalue of CASEIGNOREDP
dataa list or word
eleman atom to be remowed from list or char to be removed from word
Returns:
the input without any occurrence of elem

Implement primitiwe function REMOVE. Return a copy of data where all occurrences of elem are removed

  {
    result = empty_list;
    res_iter = result;

    while (!IS_EMPTY( data ))
    {
      if (!atom_equal( cip, CAR( data ), elem ))
      {
        if (IS_EMPTY( res_iter ))
        {
          result = res_iter = new_list( USE( CAR( data ) ), empty_list );
        }
        else
        {
          CDR( res_iter ) = new_list( USE( CAR( data ) ), empty_list );
          res_iter = CDR( res_iter );
        }
      }
      data = CDR( data );
    }
  }
  else  // data is a word
  {
    size_t len, total;
    size_t i;
    int case_ignore;
    chars_t word;
    atom_t data1;
    char_t ch;
    if (IS_ERROR(elem))
    {
      RETURN(USE(elem));
    }

    data1 = atom_to_word(elem);
    if (IS_ERROR(data1) || LENGTH(data1) != 1)
    {
      DEUSE(data1);
      RETURN(new_error(ERROR_INCOMPATIBLE_DATA, elem));
    }
    ch = (STRING(data1))[0];
    DEUSE(data1);

    if (!atom_to_boolean( cip, &case_ignore ))
    {
      case_ignore = 1;
    }
    data1 = atom_to_word(data);
    if (IS_ERROR(data1))
    {
      DEUSE(data1);
      RETURN(data);
    }
    total = len = LENGTH(data1);
    word = STRING(data1);
    if (case_ignore)
    {
      ch = TOLOWER(DEBAR(ch));
      for (i = 0; i < total; ++i)
      {
        if (TOLOWER(DEBAR(word[i]))==ch)
        {
          --len;
        }
      }
      result = create_word(len);
      len = 0;
      for (i = 0; i < total; ++i)
      {
        if (TOLOWER(DEBAR(word[i]))!=ch)
        {
          STRING(result)[len++] = word[i];
        }
      }
    }
    else
    {
      ch = DEBAR(ch);
      for (i = 0; i < total; ++i)
      {
        if (DEBAR(word[i])==ch)
        {
          --len;
        }
      }
      result = create_word(len);
      len = 0;
      for (i = 0; i < total; ++i)
      {
        if (DEBAR(word[i])!=ch)
        {
          STRING(result)[len++] = word[i];
        }
      }
    }
    DEUSE(data1);
  }
  RETURN(result);
}


//===================================================
Parameters:
dataa list or a word
Returns:
a copy of data, but elements are reversed

Implements primitive function REVERSE. Creates a reverse copy of a list or word

  {
    if (IS_EMPTY( data ))
    {
      RETURN( data );
    }

    result = empty_list;
    while (!IS_EMPTY( data ))
    {
      result = new_list( USE( CAR( data ) ), result );
      data = CDR( data );
    }
  }
  else  // data must be word
  {
    int i, n;
    data = atom_to_word( data );
    if (IS_ERROR( data ))
    {
      RETURN( data );
    }
    result = create_word(LENGTH( data ));
    n = LENGTH( data );
    for (i = 0; i < n; ++i)
    {
      STRING( result )[n - i - 1] = STRING( data )[i];
    }
    DEUSE (data);
  }

  RETURN( result );
}


//===================================================
Parameters:
dataone char word
Returns:
ASCII code of data

Implements the primitive RAWASCII. Returns ASCII code of given char, but interpred control symbols as themselves

  {
    if (LENGTH( data ) != 1)
    {
      RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data ) );
    }
#ifdef UNICODE_CHARS
    if (!OPTION_TRADITIONAL)
    {
      RETURN( new_integer( (ushort_t) STRING( data )[0] ) );
    }
#endif
    RETURN( new_integer( (byte_t) STRING( data )[0] ) );
  }

  if (IS_LIST( data ))
  {
    RETURN( new_error( ERROR_NOT_A_WORD, data ) );
  }

  if (atom_to_string( data, buff, &buff_len ))
  {
    if (buff_len == 1)
    {
#ifdef UNICODE_CHARS
      if (!OPTION_TRADITIONAL)
      {
        RETURN( new_integer( (ushort_t) buff[0] ) );
      }
#endif
      RETURN( new_integer( (byte_t) buff[0] ) );
    }

    // Word but too long
    RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data ) );
  }
  RETURN( new_error( ERROR_NOT_A_WORD, data ) );
}


//===================================================
Returns:
unique word each time it's called

Implements the primitive GENSYM. Returns unique word each time it's called The words are like that G1, G2, G3...

  {
    sym[temp_len] = TEXT( '0' ) + temp % 10;
  }
  ++num;
  RETURN( new_word( sym, num_len + 1 ) );
}


//===================================================
atom_t rt_substringp ( atom_t  cip,
atom_t  data2,
atom_t  data1 
)
Parameters:
cipvalue of CASEIGNOREDP
data1String to be search
data2String to search in
Returns:
boolean atom

Implements the primitive precicate SUBSTRINGP Returns true if data1 is substring of data2 false if it is not, or any of inputs is not word

  {
    RETURN( USE(data1) );
  }
  if (IS_ERROR( data2 ))
  {
    RETURN( USE(data2) );
  }

  // Check for lists - easy way to return FALSE
  if (IS_LIST( data1 ) || IS_LIST( data2 ))
  {
    RETURN( USE( false_true[0] ) );
  }

  // Get words from atoms
  data1 = atom_to_word( data1 );
  if (IS_ERROR( data1 ))
  {
    RETURN( data1 );
  }
  data2 = atom_to_word( data2 );
  if (IS_ERROR( data2 ))
  {
    DEUSE( data1 );
    RETURN( data2 );
  }

  if (!atom_to_boolean( cip, &case_ignore ))
  {
    case_ignore = 1;
  }

  // Here is the comparison
  for (pos = 0; pos + LENGTH( data1 ) <= LENGTH( data2 ); ++pos)
  {
    if (!word_compare( case_ignore, STRING( data2 ) + pos, LENGTH( data1 ),
          STRING( data1 ), LENGTH( data1 ) ))
    {
      result = 1;
      break;
    }
  }

  //clear and return
  DEUSE( data1 );
  DEUSE( data2 );
  RETURN( USE( false_true[result] ) );
}


//===================================================
atom_t rt_substring ( atom_t  cip,
atom_t  data2,
atom_t  data1 
)
Parameters:
cipvalue of CASEIGNOREDP
data1String to be search
data2String to search in
Returns:
boolean atom

Implements the primitive SUBSTRING Returns the position of data1 in data2 if they are words (0 if not found), or generates an error is any of the inputs is not a word.

  {
    RETURN( USE(data1) );
  }
  if (IS_ERROR( data2 ))
  {
    RETURN( USE(data2) );
  }

  // Get words from atoms
  data1 = atom_to_word( data1 );
  if (IS_ERROR( data1 ))
  {
    RETURN( data1 );
  }
  data2 = atom_to_word( data2 );
  if (IS_ERROR( data2 ))
  {
    DEUSE( data1 );
    RETURN( data2 );
  }

  if (!atom_to_boolean( cip, &case_ignore ))
  {
    case_ignore = 1;
  }

  // Here is the search
  for (pos = 0; pos + LENGTH( data1 ) <= LENGTH( data2 ); ++pos)
  {
    if (!word_compare( case_ignore, STRING( data2 ) + pos, LENGTH( data1 ),
          STRING( data1 ), LENGTH( data1 ) ))
    {
      result = pos+1;
      break;
    }
  }

  //clear and return
  DEUSE( data1 );
  DEUSE( data2 );
  RETURN( new_integer(result) );
}


//===================================================
atom_t rt_combine ( atom_t  data2,
atom_t  data1 
)
Parameters:
data1Element to add
data2List or word
Returns:
New list or word containing data2 with data1 at start

Implements the primitive COMBINE. Returns data2 with data1 inserted at front.

  {
    RETURN( new_list( USE( data1 ), USE( data2 ) ) );
  }
  data1 = atom_to_word( data1 );
  if (IS_ERROR( data1 ))
  {
    RETURN( data1 );
  }
  data2 = atom_to_word( data2 );
  if (IS_ERROR( data2 ))
  {
    DEUSE( data1 );
    RETURN( data2 );
  }

  // Copy the data
  res = create_word( LENGTH( data1 ) + LENGTH( data2 ) );
  STRNCPY( STRING( res ), STRING( data1 ), LENGTH( data1 ) );
  STRNCPY( STRING( res ) + LENGTH( data1 ), STRING( data2 ), LENGTH( data2 ) );
  *(STRING( res ) + LENGTH( data1 ) + LENGTH( data2 )) = NULL_CHAR;

  DEUSE( data1 );
  DEUSE( data2 );
  RETURN( res );
}


//===================================================
atom_t rt_quoted ( atom_t  data)
Parameters:
dataElement to quote
Returns:
quoted input if word

Implements the primitive QUOTED. Returns data if it's a list or data with quotation if is a word.

{
atom_t rt_throw ( int  count,
atom_t  data1,
atom_t  data2 
)
Parameters:
countnumber of arguments (1 or 2)
data1first parameter of THROW
data2second parameter of THROW
Returns:
unbound or error atom

Implements the THROW primitive: THROW "TOPLEVEL THROW "SYSTEM THROW "ERROR (THROW "ERROR message) THROW tag (THROW tag value)

  {
    tag = data2;
    value = data1;
  }

  // THROW "TOPLEVEL
  if (same_words( tag, word_toplevel ))
  RETURN( new_error( EXIT_BY_THROW_TOPLEVEL, tag ) );

  // THROW "SYSTEM
  if (same_words( tag, word_system ))
  RETURN( new_error( EXIT_BY_THROW_SYSTEM, tag ) );

  // THROW "ERROR
  // THROW "ERROR <message>
  if (same_words( tag, word_error ))
  {
    if (count == 1)
    {
      RETURN( new_error( EXIT_BY_THROW_ERROR, unbound ) );
    }
    else
    {
      RETURN( new_error( EXIT_BY_THROW_USER_ERROR, value ) );
    }
  }

  // THROW <tag>
  // THROW <tag> <value>
  atom_t list = new_list( USE( tag ), new_list( USE( value ), empty_list ) );
  atom_t result = new_error( count == 1 ? EXIT_BY_THROW_TAG : EXIT_BY_THROW_TAG_VALUE, list );
  DEUSE( list );
  RETURN( result );
}



//===================================================
atom_t rt_catch ( atom_t  commands,
atom_t  tag 
)
Parameters:
commandscommands monitored by catch
tagcatch tag

Dummy implementation of primitive CATCH.

{
atom_t rt_catchchk ( int  status,
atom_t  tag,
atom_t  data 
)
Parameters:
statusoutput status of data
tagcatch's tag
datavalue to check
Returns:
error or unbound atom

Checks whether the result of a catch command. If the result is thrown by throw with the same tag, then mask the result and return the thrown data. Results are also masked if the catch tag is ERROR and the thrown calue is an error-meaning error atom.

In all other cases (thrown with another tag or error) return the same result.

  {
    //catch_output_flag = 0;
    DEUSE( tag );

    return data;
  }
  //printf("CATCH TAG=");dumpln(tag);
  //printf("ERRDATA=");dumpln((ERRDATA(data)));
  //printf("THROW TAG=");dumpln(CAR(ERRDATA(data)));

  // process true errors
  if (ERRCODE( data ) < FIRST_EXIT_CODE || ERRCODE( data ) > LAST_EXIT_CODE)
  {
    if (!IS_ANY_WORD( tag ))
    {
      DEUSE( tag );
      return data;
    }

    if (!same_words( word_error, tag ))
    {
      DEUSE( tag );
      return data;
    }

    result = unbound;
    goto exit_catch;
  }

  // return throw-exception if tags are not (sub)words
  if (!IS_ANY_WORD( tag ) || !IS_ANY_WORD( CAR( ERRDATA( data ) ) ))
  {
    DEUSE( tag );
    return data;
  }
  // return throw-exception is tags are not equal
  if (!same_words( tag, CAR( ERRDATA( data ) ) ))
  {
    DEUSE( tag );
    return data;
  }

  // tags match or error captured
  result = USE( CAR( CDR( ERRDATA( data ) ) ) );

  exit_catch:
  //while (REF( data ) > 1) DEUSE( data ); //2009
  //DEUSE( last_error );
  last_error = data;
  //clear_all_errors();
  DEUSE( tag );
  //printf("result="); dumpln(result);
  //printf("last_error(%d)=",REF(last_error)); dumpln(last_error);

  catch_output_flag = 0; // forget any OUTPUT with error
  return result;
}





//===================================================
Returns:
a list describing the last error

Implementation of the primitive function ERROR. Returns a list describing the last error (if any) and then clears the error.

  {
    //printf("---"); dump_atom(p,1); printf("\n");
    //printf(">>>"); dumpln(CAR(p));
    if (!IS_EXPRESSION( CAR( p ) )) continue;
    //printf("???"); dumpln(CAR(CAR(p)));
    atom_t var = find_var( CAR( CAR( p ) ), globals );
    if (var && IS_PRIMITIVE( var )) continue;
    //printf("!!!\n");
    source = CAR( p );
    procedure = CAR( source );
  }
  //printf("--AFTER FOR-->!\n");
  
  atom_t result;
  result = new_list( USE( source ), empty_list );
  result = new_list( USE( procedure ), result );
  result = new_list( message, result );
  result = new_list( code, result );

  //REF(last_error) = 1;
  //DEUSE( last_error );
  last_error = empty_list;
  //printf("--BEFORE CLEAR-->!\n");
  //clear_all_errors(); //2011.11.30 removed, because causes bug 3445230. now all test cases work fine
  //printf("--AFTER CLEAR-->!\n");

  RETURN( result );
}



//===================================================

Dummy implementation of primitive TAG.

{
atom_t rt_goto ( int  static_link,
atom_t  parent,
atom_t  data,
atom_t  source 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
dataname of variable
sourcesource of GOTO
Returns:
unbound or error atom

Implementation of primitive GOTO. Looks for the tag in the local variables. If not found then return an error atom. If found then return the VALUE of the tag-variable.

{
atom_t rt_iftrue ( atom_t  commands)
Parameters:
commandscommands to run
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for IFTRUE primitive.

{
atom_t rt_iffalse ( atom_t  commands)
Parameters:
commandscommands to run
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for IFFALSE primitive.

{
atom_t rt_test ( atom_t  condition,
int  frame 
)
Parameters:
framebase frame pointer
conditioncondition to store
Returns:
unbound atom

Sets the value of local variable at address EBP+BASE_OFFEST_TEST to be the value of condition. This value is later accessed by IFTRUE and IFFALSE primitives.

{
Parameters:
dataone char word
Returns:
true if data contains backslashed character

Implements the primitive BACLSLASHED?.

  {
    RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data ) );
  }

  char_t ch = *STRING( data );
  DEUSE( data );
  RETURN( USE( false_true[ch != DEBAR( ch )] ) );
}




//===================================================
atom_t rt_text ( int  static_link,
atom_t  parent,
atom_t  data 
)
Parameters:
datafunction name
static_linkstatic link from the current frame
parentcurrent parent
Returns:
a list with the function's commands

Implements primitive TEXT. Returns a list containing the commands of a given function. The list could be accepted by DEFINE primitive.

  {
    n++;
    if (n > RARGS( var ))
    element = new_list( USE( NAME( CAR( x ) ) ), element ); // left inputs
    else
    result = new_list( USE( NAME( CAR( x ) ) ), result ); // right inputs
  }

  // if there were left inputs then put them as
  // a sublist in front of right inputs
  if (IS_NOT_EMPTY( element ))
  {
    result = new_list( element, result );
    element = empty_list;
  }

  // pack all inputs as the first element of the result
  result = new_list( result, empty_list );
  reslast = result;

  // group elements into lines
  for (x = BODY( var ); IS_NOT_EMPTY( x ); x = CDR( x ))
  {
    if (IS_NOT_EMPTY( element ) && GET_FLAGS( x, FLAG_NEWLINE ))
    {
      append( element, &result, &reslast );
      element = empty_list;
      elemlast = empty_list;
    }
    append( USE( CAR( x ) ), &element, &elemlast );
  }

  // process any leftovers
  if (IS_NOT_EMPTY( element ))
  {
    append( element, &result, &reslast );
  }

  RETURN( result );
}




//===================================================
atom_t rt_fulltext ( int  static_link,
atom_t  parent,
atom_t  data 
)
Parameters:
datafunction name
static_linkstatic link from the current frame
parentcurrent parent
Returns:
a list with the function's commands

Implements primitive FULLTEXT. Returns a word containing the function as source. If the source is not avaialble, then return the same result as TEXT.

{
atom_t rt_run ( int  static_link,
atom_t  parent,
atom_t  data,
int  mode 
)
Parameters:
datadata to run
static_linkstatic link from the current frame
parentcurrent parent
modeCOMPILE_AS_FUNC or COMPILE_AS_PROC
Returns:
var atom containing the compiled code

Implements primitive command/function RUN. Creates a local function with the given body, compiles it, and returns its var atom.

It is supposed that the caller of rt_run() should use the result to do the actual call of the newly compiled code.

If mode is COMPILE_AS_PROC then the compiled code is a list of commands, otherwise it is a single expression.

  {
    DEUSE( func );
    RETURN( x );
  }

  //printf("compiled tree="); dump_atom(TREE(func),1); printf("\n");
  //printf("-----------EXIT rt_run()---------------\n");
  //printf("result="); dumpln(func);
  //printf("---------------------------------------\n");
  //printf("!!!locals ="); dump_atom(LOCALS(func),1); printf("\n");
  //printf("!!!to transfer to parent="); dump_atom(NAME(PARENT(func)),1); printf("\n");
  //printf("---------------------------------------\n");

  // wrong place:: transfer all local vars from here to the parent of run
  // it is wrong, because transfer should be done after the code is
  // executed. currently the code is only compiled
  //atom_t a;
  //for( a=LOCALS(func); IS_NOT_EMPTY(a); a=CDR(a) )
  //  {
  //    //printf(" "); dump_atom(NAME(CAR(a)),1);
  //    
  //  }
  //printf("\n");
  RETURN( func );
}




//===================================================
atom_t rt_runmacro ( int  static_link,
atom_t  parent,
atom_t  data,
int  mode 
)
Parameters:
datadata to run
static_linkstatic link from the current frame
parentcurrent parent
modeCOMPILE_AS_FUNC or COMPILE_AS_PROC
Returns:
var atom containing the compiled code

Implements primitive command/function RUNMACRO. Creates a local function with the given body, compiles it as a macro, and returns its var atom.

It is supposed that the caller of rt_runmacro() should use the result to do the actual call of the newly compiled code.

If mode is COMPILE_AS_PROC then the compiled code is a list of commands, otherwise it is a single expression.

  {
    DEUSE( func );
    RETURN( x );
  }

  RETURN( func );
}




//===================================================
atom_t rt_runresult ( int  static_link,
atom_t  parent,
atom_t  data 
)
Parameters:
datadata to run
static_linkstatic link from the current frame
parentcurrent parent
Returns:
var atom containing the compiled code

Implements primitive command/function RUNRESULT by reusing rt_run() function.

{
Parameters:
datadata to fix
Returns:
fixed atom

Fixes the result of RUNRESULT. If the result is error then return it without change. If it is unbound then return empty list. Otherwise create an one-element list and put data as its element.

{
atom_t rt_define ( int  static_link,
atom_t  parent,
atom_t  value,
atom_t  name 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
namename of function
valuebody of the function

Implements the primitive command DEFINE.

  {
    DEUSE( word );
    RETURN( new_error( ERROR_NOT_A_LIST, value ) );
  }

  // create function (similarily to define_user_function)
#ifdef DEBUG_TO_END
  printf( "<TO-END-RUNTIME> DEFINING=" );
  dumpln( name );
#endif

  // create the function
  atom_t function = new_var( word_to, parent, 1 ); //DEUSE(to);
  need_descr2( function );
  SET_FLAGS( function, FLAG_FUNCTION );
  LARGS( function ) = 0;
  RARGS( function ) = 0;

  // get lists of left and right inputs
  atom_t lefts = empty_list; // left inputs
  atom_t rights = empty_list; // right inputs

  if (IS_NOT_EMPTY( value ))
  { // there is at least one element
    // is it list?
    if (IS_LIST( CAR( value ) )) rights = CAR( value );

    // now test for left parameters
    if (IS_NOT_EMPTY( rights ) && IS_LIST( CAR( rights ) ))
    {
      lefts = CAR( rights );
      rights = CDR( rights );
    }
  }

#ifdef DEBUG_TO_END
  printf( "<TO-END-RUNTIME> LEFT PARAMS=" );
  dumpln( lefts );
  printf( "<TO-END-RUNTIME> RIGHT PARAMS=" );
  dumpln( rights );
#endif

  // process left inputs
  while (IS_NOT_EMPTY( lefts ))
  {
    if (!IS_ANY_WORD( CAR( lefts ) ))
    {
      DEUSE( word );
      LOCALS( parent ) = behead( LOCALS( parent ) ); // this DEUSEs function
      return new_error( ERROR_NOT_A_WORD, lefts );
    }

    atom_t var = new_local_var( CAR( lefts ), function, 0 );
    if (IS_ERROR( var ))
    {
      DEUSE( word );
      LOCALS( parent ) = behead( LOCALS( parent ) ); // this DEUSEs function
      return var;
    }

    SET_FLAGS( var, FLAG_VARIABLE );
    LARGS( function )++;
#ifdef SAFE_MODE
    assert( LARGS( function ) < 255 );
#endif
    lefts = CDR( lefts );
  }

  // process right inputs
  while (IS_NOT_EMPTY( rights ))
  {
    if (!IS_ANY_WORD( CAR( rights ) ))
    {
      DEUSE( word );
      LOCALS( parent ) = behead( LOCALS( parent ) ); // this DEUSEs function
      return new_error( ERROR_NOT_A_WORD, rights );
    }

    atom_t var = new_local_var( CAR( rights ), function, 0 );
    if (IS_ERROR( var ))
    {
      DEUSE( word );
      LOCALS( parent ) = behead( LOCALS( parent ) ); // this DEUSEs function
      return var;
    }

    SET_FLAGS( var, FLAG_VARIABLE );
    RARGS( function )++;
#ifdef SAFE_MODE
    assert( RARGS( function ) < 255 );
#endif
    rights = CDR( rights );
  }

#ifdef DEBUG_TO_END
  printf( "<TO-END-RUNTIME> FUNC DEF=" );
  dumpln( function );
#endif


  // set offset of parameters
  int offset = BASE_OFFSET_PARAMS; // this is the start offset
  atom_t x;
  for (x = LOCALS( function ); IS_NOT_EMPTY( x ); x = CDR( x ))
  {
    //printf("set offset of "); dump(NAME(CAR(x))); printf(" to be %d\n",offset);
    OFFSET( CAR( x ) ) = offset;
    offset += sizeof ( atom_t);
  }

  // the CDR(value) is the body of the function, but it is
  // cut into sublists -- each line is a single list. So
  // all these list should be combined into one, which will
  // become the body of the function
  atom_t body = empty_list;
  atom_t body_end = empty_list;
  atom_t a;
  atom_t b;
  for (a = CDR( value ); IS_NOT_EMPTY( a ); a = CDR( a ))
  {
    b = CAR( a );
    if (IS_NOT_EMPTY( b ))
    { // the first element should have FLAG_NEWLINE set
      append( USE( CAR( b ) ), &body, &body_end );
      SET_FLAGS( body, FLAG_NEWLINE );
    }
    for (b = CDR( b ); IS_NOT_EMPTY( b ); b = CDR( b ))
    append( USE( CAR( b ) ), &body, &body_end );
  }

#ifdef DEBUG_TO_END
  printf( "<TO-END-RUNTIME> FUNC BODY=" );
  dumpln( body );
#endif



  // check whether the function is already defined
  atom_t var = find_runtime_var( word, static_link );
  if (var)
  {
    if (LARGS( var ) != LARGS( function ) || RARGS( var ) != RARGS( function ))
    {
      LOCALS( parent ) = behead( LOCALS( parent ) ); // this DEUSEs function
      atom_t result = new_error( ERROR_INCOMPATIBLE_REDEFINITION, value );
      return result;
    }

    // forget data of the old function and
    // reuse data of the new function
    DEUSE( FULLSOURCE( var ) );
    DEUSE( SOURCE( var ) );
    DEUSE( LOCALS( var ) );
    DEUSE( BODY( var ) );
    DEUSE( TREE( var ) );
    DEUSE( BINARY( var ) );

    BODY( var ) = empty_list;
    TREE( var ) = empty_list;
    BINARY( var ) = empty_list;

    SOURCE( var ) = body;
    LOCALS( var ) = USE( LOCALS( function ) );

    LOCALS( parent ) = behead( LOCALS( parent ) );
    //DEUSE(function);
    function = var;
  }
  else
  {
    DEUSE( NAME( function ) );
    NAME( function ) = USE( word );
    BODY( function ) = empty_list;
  }

  //LEVEL( function ) = level;
  ADDRESS( function ) = 0;
  PRIORITY( function ) = PRIORITY_FUN;

  SOURCE( function ) = body;
  FULLSOURCE( function ) = unbound;

  //DEUSE( input );
#ifdef DEBUG_TO_END
  printf( "<TO-END> DEFINED FUNCTION " );
  dumpln( NAME( function ) );
  printf( "<TO-END>           SOURCE " );
  dumpln( SOURCE( function ) );
  printf( "<TO-END>           BODY   " );
  dumpln( BODY( function ) );
  printf( "<TO-END>           TREE   " );
  dumpln( TREE( function ) );
#endif

  DEUSE( word );

  atom_t y = compile_function( function, COMPILE_AS_PROC, COMPILE_AS_NON_MACRO );
  if (IS_ERROR( y )) return y;

  return unbound;
}


//===================================================
atom_t rt_for ( atom_t  body,
atom_t  limits,
atom_t  var 
)
Parameters:
bodybody of FOR command
limitslist of initial and final limits
varname of control variable
Returns:
unbound atom

This is a dummy implementation, which is not used except for reserving a unique address for FOR primitive.

{
Parameters:
datafilename of the dynamic library
Returns:
Number of library handle

Implements the primitive LIBLOAD. Returns the library handle.

  {
    RETURN( new_error( ERROR_NOT_A_WORD, data ) );
  }

  // convert char_t* into char*
  int len = LENGTH( data );
  chars_t ptr = STRING( data );
  char filename[len + 1+3+1+2];
  int i=0;
  //#ifndef WINDOWS
  //filename[i++] = 'l';
  //filename[i++] = 'i';
  //filename[i++] = 'b';
  //len += 3;
  //#endif

  for (; i < len; i++) filename[i] = *(ptr++);
  filename[len] = '\0';
  //#ifndef WINDOWS
  //filename[len++] = '.';
  //filename[len++] = 's';
  //filename[len++] = 'o';
  //filename[len] = '\0';
  //#endif

  //dumpln(data);
  //fprintf(stderr, "loading library %s\n\n\n",filename);
  handle = dlopen( filename, RTLD_LAZY );
  //if (!handle) fputs(dlerror(), stderr);
  //fprintf(stderr, "\nloaded result=%d.\n",(int)handle);

  return new_integer( (int) handle );
}


//===================================================
Parameters:
datahandle of the dynamic library
Returns:
unbound atom

Implements the primitive LIBFREE.

{
atom_t rt_blocksize ( int  static_link,
atom_t  parent,
atom_t  prototype 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
prototypepack prototype
Returns:
the pack size in bytes

Implements primitive PACKSIZE. Returns the size of a pack in bytes. The pack is defined by a prototype list. If unknown type is reached then return error atom.

  {
    RETURN( USE( ATOMS(prototype) ) );
  }
  else
  {
    RETURN( new_error(ERROR_NOT_BLOCK_OR_DEF,prototype) );
  }
}



//===================================================
atom_t rt_listtoblock ( int  static_link,
atom_t  parent,
atom_t  prototype,
atom_t  data 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
datadata to pack
prototypepack prototype
Returns:
memory atom with packed data

Implements primitive LISTTOBLOCK. Creates a memory atom big enough to hold all packed data.

  {
    DEUSE( memory );
    RETURN( res );
  }

  RETURN( memory );
}




//===================================================
atom_t rt_blocktolist ( int  static_link,
atom_t  parent,
atom_t  prototype,
atom_t  data 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
datadata to unpack
prototypepack prototype
Returns:
memory atom with packed data

Implements primitive BLOCKTOLIST. It 'reads' packed data from memory atom and returns a list of unpacked data.

  {
    int64_t addr;
    GET_INT( data, addr );
    ptr = (void*)(int)addr;
  }

  atom_t res = traverse_pack( static_link, parent, prototype, empty_list, ptr, MEM_STRUCT_UNPACK );
  return res;
}



//===================================================
Parameters:
dataatom which address is returned
Returns:
the address of an atom

Implements primitive DATAADDR. Returns an integer atom which is the address of the data atom.

{
atom_t rt_listintoblock ( int  static_link,
atom_t  parent,
atom_t  prototype,
atom_t  dest,
atom_t  data 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
destdestination for packed data
prototypepack prototype
datadata to pack
Returns:
unbound or error atom

Implements primitive PACKTO. Packs data into address specified by dest which must be either a memory atom or an address (i.e. integer atom).

{
atom_t rt_funcaddr ( int  static_link,
atom_t  parent,
atom_t  data 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
datafunction name
Returns:
the address of a function with given name

Implements primitive FUNCADDR. Returns the address of the function which name is the value of data. If there is no function, then return error atom.

{
atom_t rt_external ( int  static_link,
atom_t  parent,
atom_t  handle,
atom_t  prototype,
atom_t  name 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
handlehandle of library
prototypeexternal function prototype
namefunction to externalize
Returns:
unbound or error atom

Implements primitive EXTERNAL. Creates a trampoline code which prepares the stack by converting atoms into C data types.

                                                   :FLAG_FUNCTION );

  // get external name
  atom_t external_name = CAR( prototype );
  prototype = CDR( prototype );
  if( !IS_ANY_WORD(external_name) )
  RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );
  //printf("external name = "); dumpln(external_name);

  // check the correct order of parameters
  if( list_length(prototype) != RARGS(var) )
  RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );

  // now process parameters one-by-one
  atom_t params;
  int offset = BASE_OFFSET_PARAMS+(RARGS(var)-1)*sizeof(atom_t);
  for( ; IS_NOT_EMPTY(prototype); prototype=CDR(prototype) )
  {
    // get one type from the prototype
    type = CAR( prototype );
    c_type = get_c_type( static_link, parent, type );
    class = c_types[c_type].class;

    if( class==C_TYPE_STRUCT || class==C_TYPE_UNKNOWN )
    RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );

    // now find parameter with given offset
    for( params=LOCALS(var); IS_NOT_EMPTY(params); params=CDR(params))
    {
      atom_t param = CAR( params );
      if( !IS_VARIABLE(param) ) continue; // functions/commands not allowerd
      if( !IS_NORMAL(param) )   continue; // tags/runtimes not allowed
      if( OFFSET(param)==offset )
      {
        VARTYPE( param ) = VAR_TYPE_EXTERNAL+c_type;
        //printf(" :::param "); dump(NAME(param)); printf(" is class=%d name=%S\n", c_type, c_types[c_type].name);
        break;
      }
    }

    offset -= sizeof( atom_t );
  }

#ifdef SAFE_MODE
  for( params=LOCALS(var); IS_NOT_EMPTY(params); params=CDR(params))
  assert( IS_EXTERNAL(CAR(params)) );
#endif

  //printf("search function "); dump(external_name); printf(" in handle "); dumpln(handle);

  // convert char_t* into char*
  int len = LENGTH( external_name );
  chars_t ptr = STRING( external_name );
  char func_name[len + 1];
  int i;
  for (i = 0; i < len; i++) func_name[i] = *(ptr++);
  func_name[len] = '\0';

  void* address = dlsym( (void*)hnd, func_name );

  if( !address )
  RETURN( new_error( ERROR_NOT_A_FUNCTION, external_name ) );

  //printf("external address=%x\n",(int)address);

  ADDRESS( var ) = (int)address;
  compile_external_function( var );
  RETURN( unbound );
}




//===================================================
atom_t rt_internal ( int  static_link,
atom_t  parent,
atom_t  prototype,
atom_t  name 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
prototypeinternal function prototype
namefunction to internalize
Returns:
unbound or error atom

Implements primitive INTERNAL. Creates a trampoline code which prepares the stack by converting C data types into atoms.

                                                   :FLAG_FUNCTION );

  // check the correct order of parameters
  if( list_length(prototype) != RARGS(var) )
  RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );

  // now process parameters one-by-one
  atom_t params;
  int offset = BASE_OFFSET_PARAMS+(RARGS(var)-1)*sizeof(atom_t);
  for( ; IS_NOT_EMPTY(prototype); prototype=CDR(prototype) )
  {
    // get one type from the prototype
    type = CAR( prototype );
    c_type = get_c_type( static_link, parent, type );
    class = c_types[c_type].class;

    if( class==C_TYPE_STRUCT || class==C_TYPE_UNKNOWN )
    RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );

    // now find parameter with given offset
    for( params=LOCALS(var); IS_NOT_EMPTY(params); params=CDR(params))
    {
      atom_t param = CAR( params );
      if( !IS_VARIABLE(param) ) continue; // functions/commands not allowerd
      if( !IS_NORMAL(param) )   continue; // tags/runtimes not allowed
      if( OFFSET(param)==offset )
      {
        VARTYPE( param ) = VAR_TYPE_INTERNAL+c_type;
        //printf(" :::param "); dump(NAME(param)); printf(" is class=%d name=%S offset=%d\n", c_type, c_types[c_type].name,offset);
        break;
      }
    }

    offset -= sizeof( atom_t );
  }

#ifdef SAFE_MODE
  for( params=LOCALS(var); IS_NOT_EMPTY(params); params=CDR(params))
  assert( IS_INTERNAL(CAR(params)) );
#endif

  compile_internal_function( var, static_link );
  RETURN( unbound );
}




//===================================================
atom_t rt_stackframe ( int  static_link,
atom_t  parent,
atom_t  offset,
atom_t  frame 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
offsetoffset in the stack frame
framestack frame number
Returns:
value at offset of a stack frame or error atom

Implements primitive _STACKFRAME. Goes to stack frame number FRAME (0 - current frame, 1 - parent frame, etc.) and returns the value at given OFFSET relative to the stack frame. OFFSET is given in term of words.

{
atom_t rt_stackframeatom ( int  static_link,
atom_t  parent,
atom_t  offset,
atom_t  frame 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
offsetoffset in the stack frame
framestack frame number
Returns:
atom at offset of a stack frame or error atom

Implements primitive _STACKFRAMEATOM. Goes to stack frame number FRAME (0 - current frame, 1 - parent frame, etc.) and returns the value at given OFFSET relative to the stack frame. OFFSET is given in term of words. The value is assumed to be an atom.

{

This definition just reserves an address for rt_int3, so that compile_function() can easily detect it.

{
atom_t rt_load ( atom_t  data)

It is supposed that the caller of rt_run() should use the result to do the actual call of the newly compiled code.

If mode is COMPILE_AS_PROC then the compiled code is a list of commands, otherwise it is a single expression.

Parameters:
dataname of file to load
Returns:
var atom containing the compiled code

Implements primitive command LOAD. Creates a local function with the given body, compiles it, and

{
Returns:
list atom containing command line

Implements primitive function COMMANDLINE. Returns a list containing the command-line arguments.

{
atom_t rt_openfile_mode ( atom_t  filename,
char *  mode,
int  call_mode 
)
Parameters:
modeopen mode (read, write, ...)
filenamename of binary file
call_modeCOMPILE_AS_FUNC or COMPILE_AS_PROC
Returns:
var atom containing the file handle or error atom

Opens a file stream with given filename and mode. The filename is in an atom, while the mode is in a string.

  {
    DEUSE( fn );
    DEALLOC( file_names[i] );
    file_names[i]   = NULL;
    file_handles[i] = NULL;

    last_os_error = errno;
    RETURN( new_error( ERROR_OS_ERROR, filename ) );
  }
  
  DEUSE( fn );

  if( call_mode==COMPILE_AS_FUNC )
  {
    RETURN( new_integer( (int)file_handles[i] ) );
  }
  else
  {
    RETURN( unbound );
  }
};




//===================================================
atom_t rt_openfile ( atom_t  mode,
atom_t  filename,
int  call_mode 
)
Parameters:
modeopen mode (read, write, ...)
filenamename of binary file
call_modeCOMPILE_AS_FUNC or COMPILE_AS_PROC
Returns:
var atom containing the file handle or error atom

Implements primitive command OPENFILE. Opens a binary file with given filename and mode. Files opened with PACKOPEN should be processed with other PACK-aware functions and commands.

{
atom_t get_file_index ( atom_t  file,
int *  index 
)
Parameters:
filefile handle or file name
indexvariable to store the index
Returns:
unbound or error atom

Searches for an opened file assuming that file is a file handle. If it cannot be converted to a number, assumes it is a file name. Returns error atom (if getting the handle or the filename failed) or unbound atom if OK. In the latter case index contains the index of the file. If index=-1, then the file is not opened so far.

If error atom is returns, it is already USEed, so the caller should not reUSE it.

  { // the filename is a number
    *index = find_file_by_handle( (FILE*)(int)handle );
  }
  
  if( *index<0 )
  { // the filename may be a string
    atom_t fn = atom_to_real_word( file );
    if( IS_ERROR(fn) ) {DEUSE(fn); RETURN(USE(file))};
    char* ch = FILENAME(STRING(fn));
    *index = find_file_by_filename( ch );
    DEALLOC( ch );
    DEUSE( fn );
  }

  //is file opened?
  if( *index<0 )
  {
    RETURN( new_error( ERROR_FILE_NOT_OPENED, file ) );
  }
  
  RETURN( unbound );
};



//===================================================
Parameters:
filefile to close
Returns:
unbound atom

Implements primitive command CLOSEFILE. Closes a file identified by either by its handle (if file contains a number) or by its name otherwise.

{
atom_t rt_readblock ( int  static_link,
atom_t  parent,
atom_t  size 
)
Parameters:
static_linkstatic link from the current frame
parentcurrent parent
sizesize of the block and number of bytes to read
Returns:
memory or error atom or empty list

Implements primitive command READBLOCK. Reads block of bytes from a file opened with OPENFILE and set as reading file with SETREAD. The size of the data being read is measured in bytes. The read data is placed in a newly created memory block.

Returns an empty list if reading failed because of end of file, or if the reading is from the standard input.

  { // size is a prototype
    sizeatom = rt_blocksize( static_link, parent, size );
    if( IS_ERROR(sizeatom) )
    {
      RETURN( sizeatom );
    }
    datasize = INTEGER(sizeatom);
  }
  else
  { // size must be an integer
    if (!atom_to_int( size, &datasize ))
    {
      RETURN( new_error( ERROR_NOT_AN_INTEGER, size ) );
    }
    sizeatom = USE(size);
  }
  
  atom_t data = new_mem( datasize );

  if( !fread( MEMORY(data), datasize, 1, input_stream ) )
  {
    DEUSE( data );
    DEUSE( sizeatom );
    if( errno )
    {
      errno = EIO;
      last_os_error = errno;
      return new_error( ERROR_OS_ERROR, size );
    }
    else
    {
      data = empty_list;
    }
  }
  else
  {
    DEUSE( ATOMS(data) );
    ATOMS(data) = sizeatom;
  }
  RETURN( data );
};



//===================================================
atom_t rt_readinblock ( atom_t  block,
int  call_mode 
)
Parameters:
blockblock to read data to
call_modeCOMPILE_AS_FUNC or COMPILE_AS_PROC
Returns:
memory or error atom or empty list

Implements primitive command READINBLOCK. Reads block of bytes from a file opened with OPENFILE and set as reading file with SETREAD. The size of the data is taken from the memory block where the data is read.

Returns an empty list if reading failed because of end of file, or if the reading is from the standard input.

  {
    RETURN( new_error(ERROR_NOT_BLOCK_OR_DEF,block) );
  }

  if( !fread( MEMORY(block), INTEGER(ATOMS(block)), 1, input_stream ) )
  {
    if( errno )
    {
      errno = EIO;
      last_os_error = errno;
      return new_error( ERROR_OS_ERROR, block );
    }
    else
    {
      if( call_mode==COMPILE_AS_FUNC )
        { RETURN( empty_list ); }
      else
        { RETURN( unbound ); }
    }
  }

  if( call_mode==COMPILE_AS_FUNC )
    { RETURN( USE(block) ); }
  else
    { RETURN( unbound ); }
};



//===================================================
Parameters:
datapacked data to be written
Returns:
unbound or error atom

Implements primitive command WRITEBLOCK. Writes a block of bytes to a file opened with OPENFILE and set for writing with SETWRITE. The size of the data being written is taken from the memory block containing the packed data.

Returns an empty list if the output file is the standard output.

  {
    RETURN( new_error( ERROR_NOT_A_MEM, data ) );
  }
  if (!atom_to_int( ATOMS(data), &size ))
  {
    RETURN( new_error( ERROR_NOT_AN_INTEGER, ATOMS(data) ) );
  }

  fwrite( MEMORY(data), size, 1, output_stream );
  if( errno )
  {
    last_os_error = errno;
    RETURN( new_error( ERROR_OS_ERROR, data ) );
  }

  RETURN( unbound );
};



//===================================================
Returns:
Number atom - read char as a word

Implements the primitive function readchar. Reads a single character from the read stream and outputs that character as a word.

  {
    RETURN( new_word( &ch, 1 ) );
  }
}



//===================================================
Parameters:
datanumber of characters to read
Returns:
Number atom - read chars as a word

Implements the primitive function readchars. Reads a given number of characters from the read stream and outputs them as a word.

  {
    RETURN( new_error( ERROR_NOT_A_NUMBER, data ) );
  }

  // Allocate memory
  res = create_word( count+1 ); // +1 is for the terminating 0
  chs = STRING(res);
  while( count )
  {
    *chs = (char_t)inner();
    chs++;
    count--;
  }
  *chs = TEXT('\0');

  RETURN( res );
}



//===================================================
Returns:
Number atom - read line as a word

Implements the primitive function readrawline. Reads a single line from the read stream and outputs that line as a word.

  {
    return( empty_list );
  }

  while( (ch!=TEXT('\n')) && (ch!=NO_MORE) )
  {
    if( !bufspace )
    {
      buffer = REALLOC( buffer, (bufsize+bufstep)*sizeof(char_t) );
      bufspace = bufstep;
      bufsize = bufsize+bufstep;
      bufstep = bufstep+1;
    }

    *(buffer+buflen) = ch;
    buflen++;
    bufspace--;

    ch = inner();
  }

  if( !buffer ) return( empty_list );
  res = new_word( buffer, buflen );
  DEALLOC( buffer );
  return res;
}



//===================================================
Returns:
Number atom - read line as a word

Implements the primitive function readword. Reads a single line from the read stream and outputs that line as a word. Processes backslashes, vertical bars.

{
Returns:
Number atom - read line as a list

Implements the primitive function readlist. Reads a single line from the read stream and outputs that line as a list. Processes all special characters except semicolon ";".

{
atom_t rt_getenv ( atom_t  data)
Parameters:
dataenvironment variable name
Returns:
the value of envronment variable

Implements primitive GETENV. Returns the value of the environment variable which name is the value of data. If there is no such variable, then return empty list.

  {
    chars_t value = ASCII_to_UTF16( asciivalue );
    res = new_word( value, -1 );
    DEALLOC( value );
  }
  else
  {
    res = empty_list;
  }

  DEUSE( word );
  DEALLOC( varname );
  RETURN( res );
}



//===================================================
Returns:
a list of all envronment variables

Implements primitive GETENVS. Returns a list of all environment variables.

  {
    char* var = *env;
    char* v=var;
    while( (*v!='=') && (*v!='\n') ) v++;
    oldv = *v;
    *v = '\0';
    chars_t uname = ASCII_to_UTF16( var );
    chars_t uvalue = ASCII_to_UTF16( v+1 );
    *v = oldv;

    atom_t pair = new_list( new_word(uvalue,-1), empty_list );
    pair = new_list( new_word(uname,-1), pair );
    res = new_list( pair, res );
    
    DEALLOC( uname );
    DEALLOC( uvalue );
    env++;
  }
  RETURN( res );
}


//===================================================
Returns:
true or false atom

Implements the primitive function eof?. Outputs true if there are no more characters to be read, or false otherwise.

{
Returns:
word atom

Implements the primitive function currentfolder. Outputs a word atom containing the name of the current folder.

{
Parameters:
namename of a folder to make
Returns:
unbound or error atom

Implements the primitive function makefolder. Create a folder with given name relative to the current folder. Outputs unbound or error atom.

{
Parameters:
namename of a folder to erase
Returns:
unbound or error atom

Implements the primitive function erasefolder. Erases an empty folder with given name relative to the current folder. Outputs unbound or error atom.

{
Parameters:
namename of a folder to change to
Returns:
unbound or error atom

Implements the primitive function changefolder. Changes the current folder to a given folder. Outputs unbound or error atom.

{
Parameters:
namename of a folder to test
Returns:
boolean or error atom

Implements the primitive function folder?. Returns "true if a folder with the given name exists. Otherwise return "false.

                                                 :0 ]);
  
  DEUSE( word );
  DEALLOC( fname );
  
  RETURN( res );
}




//===================================================
atom_t rt_renamefolder_or_file ( atom_t  toname,
atom_t  fromname,
int  folders 
)
Parameters:
tonamenew name of a folder
fromnameold name of a folder
foldersif !=0, rename a folder, otherwise a file
Returns:
unbound or error atom

Renames a folder or a file given its old and new names. Outputs unbound or error atom.

{
atom_t rt_renamefolder ( atom_t  toname,
atom_t  fromname 
)
Parameters:
tonamenew name of a folder
fromnameold name of a folder
Returns:
unbound or error atom

Implements the primitive function renamefolder. Renames a folder give its old and new names. Outputs unbound or error atom.

{
atom_t rt_renamefile ( atom_t  toname,
atom_t  fromname 
)
Parameters:
tonamenew name of a file
fromnameold name of a file
Returns:
unbound or error atom

Implements the primitive function renamefile. Renames a file given its old and new names. Outputs unbound or error atom.

{
atom_t rt_folders_or_files ( atom_t  name,
int  folders 
)
Parameters:
namename of a folder to scan
foldersif !=0, scans for folders, otherwise for files
Returns:
list or error atom

Returns a list of folders' names (if folders!=0) of files' name (if folders==0) in a given folder.

  {
    // open the folder
    DIR *dp;
    struct dirent *de;
    
    dp = opendir( fname );
    if( dp )
    {
      char long_name[PATH_MAX];
      int len = strlen( fname );
      strcpy( long_name, fname );
      long_name[len] = '/';
      len++;
      
      // scan the files one by one
      atom_t last = empty_list;
      de = readdir( dp );
      while( de )
      {
        struct stat buffer;
        strcpy( long_name+len, de->d_name );
        int err = stat(long_name,&buffer);
        if( err==0 )
        {
          int ok;
          if( folders )
          ok = S_ISDIR(buffer.st_mode);
          else
          ok = S_ISREG(buffer.st_mode);
          if( ok )
          {
            chars_t buf = UNFILENAME(de->d_name);
            atom_t word = new_word( buf, -1 );
            append( word, &res, &last );
            DEALLOC( buf );
          }
        }
        de = readdir( dp );
      }
      closedir( dp );
    }
  }
  
  DEUSE( word );
  DEALLOC( fname );
  
  RETURN( res );
}



//===================================================
Parameters:
namename of a folder to list
Returns:
list or error atom

Implements the primitive function folders. Returns a list of folders' names in a given folder.

{
atom_t rt_files ( atom_t  name)
Parameters:
namename of a folder to list
Returns:
list or error atom

Implements the primitive function files. Returns a list of files' names in a given folder.

{
Parameters:
namename of a file to erase
Returns:
unbound or error atom

Implements the primitive function erasefile. Erases a file with given name relative to the current folder. Outputs unbound or error atom.

{
atom_t rt_filep ( atom_t  name)
Parameters:
namename/path of a file to test
Returns:
boolean or error atom

Implements the primitive function file?. Returns "true if a file with the given name or path exists. Otherwise return "false.

                                                 :0 ]);
  
  DEUSE( word );
  DEALLOC( fname );
  
  RETURN( res );
}



//===================================================
Parameters:
namename of a file
Returns:
integer or error atom

Implements the primitive function filesize. Returns size of the file in bytes if the file exists. Otherwise returns -1.

{
Parameters:
namename of a file
Returns:
list or error atom

Implements the primitive function filetimes. Returns a list of three times (each represented as a number): [creation modification access] If the file does not exist or cannot be accessed then returns an empty list.

  {
    res = new_list( new_integer( buffer.st_atime ), res );
    res = new_list( new_integer( buffer.st_mtime ), res );
    res = new_list( new_integer( buffer.st_ctime ), res );
  }
  
  DEUSE( word );
  DEALLOC( fname );
  
  RETURN( res );
}




//===================================================
atom_t rt_openread ( atom_t  name,
int  call_mode 
)
Parameters:
namename of a file
call_modeCOMPILE_AS_FUNC or COMPILE_AS_PROC
Returns:
file handle or error atom

Implements the primitive function openread. Returns an integer atom with the file handle or an error atom.

{
atom_t rt_openwrite ( atom_t  name,
int  call_mode 
)
Parameters:
namename of a file
call_modeCOMPILE_AS_FUNC or COMPILE_AS_PROC
Returns:
file handle or error atom

Implements the primitive function openwrite. Returns an integer atom with the file handle or an error atom.

{
atom_t rt_openappend ( atom_t  name,
int  call_mode 
)
Parameters:
namename of a file
call_modeCOMPILE_AS_FUNC or COMPILE_AS_PROC
Returns:
file handle or error atom

Implements the primitive function openappend. Returns an integer atom with the file handle or an error atom.

{
atom_t rt_openupdate ( atom_t  name,
int  call_mode 
)
Parameters:
namename of a file
call_modeCOMPILE_AS_FUNC or COMPILE_AS_PROC
Returns:
file handle or error atom

Implements the primitive function o/c/te. Returns an integer atom with the file handle or an error atom.

{
Parameters:
filefile to set as a reader
Returns:
unbound or error atom

Implements primitive command SETREAD. Sets a given file handle as a reader file (i.e. input stream). If file is an empty list, then reset the input stream to the default one (usually stdin).

  {
    int index;
    atom_t res = get_file_index( file, &index );
    if( IS_ERROR(res) ) RETURN(res); // USE is done by get_file_index()
  
    input_stream = file_handles[index];
  }

  RETURN( unbound );
};




//===================================================
Parameters:
filefile to set as a writer
Returns:
unbound or error atom

Implements primitive command SETWRITE. Sets a given file handle as a writer file (i.e. output stream). If file is an empty list, then reset the output stream to the default one (usually stdout).

  {
    int index;
    atom_t res = get_file_index( file, &index );
    if( IS_ERROR(res) ) RETURN(res); // USE is done by get_file_index()
  
    output_stream = file_handles[index];
  }
  
  RETURN( unbound );
};




//===================================================
Returns:
empty list or word atom

Implements primitive command READER. Returns the name of the current input stream or an empty list if it is stdin.

  {
    int i = find_file_by_handle( input_stream );
    #ifdef SAFEMODE
      assert( i>-1 );
    #endif
    chars_t name = ASCII_to_UTF16( file_names[i] );
    res = new_word( name, -1 );
    DEALLOC( name );
  }

  RETURN( res );
};



//===================================================
Returns:
empty list or word atom

Implements primitive command WRITER. Returns the name of the current output stream or an empty list if it is stdout.

  {
    int i = find_file_by_handle( output_stream );
    #ifdef SAFEMODE
      assert( i>-1 );
    #endif
    chars_t name = ASCII_to_UTF16( file_names[i] );
    res = new_word( name, -1 );
    DEALLOC( name );
  }

  RETURN( res );
};



//===================================================
Returns:
empty list atom

Implements primitive command ALLOPEN. Returns a list of the names of all opened files.

    {
      chars_t name = ASCII_to_UTF16( file_names[i] );
      atom_t word = new_word( name, -1 );
      DEALLOC( name );
     
      append( word, &res, &last );
    }

  RETURN( res );
};



//===================================================
Returns:
unbound atom

Implements primitive command CLOSEALL. Closes all opened files, returns unbound atom.

{
Parameters:
posfile position for the reader
Returns:
unbound or error atom

Implements primitive command SETREADPOS. Sets the reading position of the reader (i.e. input stream). Is pos>=0 the position is measured from the beginning of the file, otherwise - from the end.

  {
    fseek( input_stream, position, SEEK_END );
  }

  RETURN( unbound );
};




//===================================================
Returns:
integer or error atom

Implements primitive command READPOS. Returns the reading position of the reader (i.e. input stream).

{
Parameters:
posfile position for the writer
Returns:
unbound or error atom

Implements primitive command SETWRITEPOS. Sets the writing position of the writer (i.e. output stream). Is pos>=0 the position is measured from the beginning of the file, otherwise - from the end.

{
Returns:
integer or error atom

Implements primitive command WRITEPOS. Returns the writinging position of the writer (i.e. output stream).

{
Returns:
integer atom

Implements primitive function TIEMZONE. Returns the timezone difference with GMT in seconds.


Variable Documentation

char* file_names[FOPEN_MAX] = { [0 ... (FOPEN_MAX-1)]=NULL }
FILE* file_handles[FOPEN_MAX] = { [0 ... (FOPEN_MAX-1)]=NULL }

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