|
Lhogho
0.0.027
|
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 test_elem_and_destroy_if_error | ( | elem, | |
| list | |||
| ) |
{ \
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 |
| void rt_set_var_value | ( | int | static_link, |
| atom_t | parent, | ||
| atom_t | var, | ||
| atom_t | value | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| var | the variable |
| value | the 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 );
}
//===================================================
| void init_runtime | ( | ) |
So far nothing to be initialized
{
| void finit_runtime | ( | ) |
Deallocates all names of unclosed files and closes them.
{
| int find_file_by_filename | ( | char * | filename | ) |
| filename | name of a file |
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 | ) |
| handle | handle of a file |
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 | ||
| ) |
| source | source of the command |
| data | value to check |
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;
}
//===================================================
| source | source of the command |
| data | value to check |
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 | ||
| ) |
| source | source of the expression |
| data | value to check |
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.
| atom_t rt_boolchk | ( | atom_t | source, |
| atom_t | data | ||
| ) |
| source | source of the command |
| data | value to check |
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 );
}
//===================================================
| data | value to check |
| source | source of the function |
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 );
}
//===================================================
| data | value to check |
| source | source of the expression |
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 );
}
//===================================================
| from | initial value |
| to | final value |
| step | step value (could be UNBOUND) |
| step_value | pointer to step value |
| source | source of the expression |
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 );
}
//===================================================
| pdl | value of PRINTDEPTHLIMIT |
| pwl | value of PRINTWIDTHLIMIT |
| fpp | value of FULLPRINTP |
| data | number of inputs of PRINT |
Implements the primitive PRINT. The only input contains the number of inputs which are pulled out from the stack.
| count | number of inputs of + |
| data1 | first input |
| data2 | second input |
Implements the primitive operator +. If + is used as infix operator, then count=2, otherwise count=1 and only data2 input is used.
{
| count | number of inputs of - |
| data1 | first input |
| data2 | second input |
Implements the primitive operator -. If - is used as infix operator, then count=2, otherwise count=1 and only data2 input is used.
{
| data1 | first input |
| data2 | second input |
Implements the primitive operator *.
{
| data1 | first input |
| data2 | second input |
Implements the primitive operator /.
{
| data | number of inputs of SUM |
Implements the primitive SUM. The only input contains the number of inputs which are pulled out from the stack. Returns their sum
| atom_t rt_difference | ( | atom_t | data2, |
| atom_t | data1 | ||
| ) |
| data1 | first input |
| data2 | second input |
Implements the aritmetic primitive DIFFERENCE
{
| atom_t rt_unminus | ( | atom_t | data | ) |
| data | argument |
Implements the aritmetic primitive MINUS
{
| atom_t rt_product | ( | int | data | ) |
| data | number of inputs of PRODUCT |
Implements the primitive PRODUCT. The only input contains the number of inputs which are pulled out from the stack. Returns their product
| atom_t rt_remainder | ( | atom_t | data2, |
| atom_t | data1 | ||
| ) |
| data1 | first input |
| data2 | second input |
Implements the aritmetic primitive REMAINDER
{ RETURN( new_integer( x % y ) ); }
else
{ RETURN( new_integer( 0 ) ); }
}
//===================================================
| data | argument |
Implements the aritmetic primitive INT
{
| data | argument |
Implements the aritmetic primitive ROUND
{
| data | argument |
Implements the aritmetic primitive SQRT Calculates square root from the number
{
| base | base number |
| power | power to calculate |
base on power Implements the aritmetic primitive POWER
{
| power | power to calculate |
e on power Outputs e (2.718281828+) to the input power.
{
| data | argument |
Outputs the common logarithm of the input
{
| data | argument |
Outputs natural logarithm of the input
{
| data | argument |
Outputs the absolute value of the input
{
| data | argument in degrees |
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 ) );
}
//===================================================
| data | argument in degrees |
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 ) );
}
//===================================================
| count | number of arguments (1 or 2) |
| data1 | first argument |
| data2 | second argument |
Outputs the arctangent, in degrees, of its input.
| atom_t rt_radarctan | ( | int | count, |
| atom_t | data2, | ||
| atom_t | data1 | ||
| ) |
| count | number of arguments (1 or 2) |
| data1 | first argument |
| data2 | second argument |
Outputs the arctangent, in radians, of its input.
| static_link | static link from the current frame |
| parent | current parent |
| name | name of variable |
| value | new 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 );
}
//===================================================
| static_link | static link from the current frame |
| parent | current parent |
| name | name of variable |
| value | new value of variable |
Implements the primitive command NAME. It uses the same code as MAKE.
{
| static_link | static link from the current frame |
| parent | current parent |
| data | count 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 | ||
| ) |
| x | first number |
| y | second number |
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 | ||
| ) |
| cip | to ignote or not case in comparison |
| w1 | first word |
| w1_len | first word length |
| w2 | second word |
| w2_len | second word length |
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 | ||
| ) |
| cip | value of CASEIGNOREDP |
| data1 | first atom |
| data2 | second atom |
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 | ||
| ) |
| cip | value of CASEIGNOREDP |
| data1 | first list |
| data2 | second list |
Compares two lists. if both are equal returns not 0 number Returns 0 if lists are diferent.
| cip | value of CASEIGNOREDP |
| data1 | first input |
| data2 | second input |
Implements compare operation EQUALP
{
RETURN( new_error( ERROR_MISSING_VALUE, data2 ) );
}
RETURN( USE( false_true[comp > 0] ) );
}
//===================================================
| cip | value of CASEIGNOREDP |
| data1 | first input |
| data2 | second input |
Implements compare operation NOTEQUALP
{
RETURN( new_error( ERROR_MISSING_VALUE, data2 ) );
}
RETURN( USE( false_true[comp == 0] ) );
}
//===================================================
| data1 | first number |
| data2 | second number |
Implements compare operation LESSP Arguments must be numbers
{
| data1 | first number |
| data2 | second number |
Implements compare operation GREATERP Arguments must be numbers
{
| data1 | first number |
| data2 | second number |
Implements compare operation LESSEQUALP Arguments must be numbers
{
| data1 | first number |
| data2 | second number |
Implements compare operation GREATEREQUALP Arguments must be numbers
{
| cip | value of CASEIGNOREDP |
| data1 | first word |
| data2 | second word |
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] ) );
}
//===================================================
| data | return value of the Logo program |
This is a dummy implementation, which is not used except for reserving a unique address for OUTPUT primitive.
{
| atom_t rt_maybeoutput | ( | atom_t | data | ) |
| data | return value of the Logo program |
This is a dummy implementation, which is not used except for reserving a unique address for MAYBEOUTPUT primitive.
{
This is a dummy implementation, which is not used except for reserving a unique address for STOP primitive.
{
| source | source of the command |
This function is used to dump the source of some comands (like OUTPUT).
{
| atom_t rt_predump | ( | atom_t | source | ) |
| source | source of the command |
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.
{
| data | number of inputs of AND |
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] ) );
}
//===================================================
| data | number of inputs of OR |
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] ) );
}
//===================================================
| data | boolean argument |
Outputs true is argument is false and false if argument is true
{
| data | word or list argument |
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 ) );
}
//===================================================
| atom_t rt_butfirst | ( | atom_t | data | ) |
| data | word or list argument |
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 ) );
}
//===================================================
| data | A list |
Inserts in result first letter of element if it is word or first element of element if it is list
| atom_t rt_butfirsts | ( | atom_t | data | ) |
| data | A list |
data without firstIf 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 );
}
//===================================================
| data | word or list argument |
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 ) );
}
//===================================================
| atom_t rt_butlast | ( | atom_t | data | ) |
| data | word or list argument |
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 ) );
}
//===================================================
| data | word or list argument |
| index | integer index of element to get |
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 ) );
}
//===================================================
| count | number of parameters |
This is a dummy implementation, which is not used except for reserving a unique address for IF primitive.
{
| repcount | number of repetitions |
| commands | commands to repeat |
This is a dummy implementation, which is not used except for reserving a unique address for REPEAT primitive.
{
dummy implementation of primitive command DO.WHILE
| condition | repetition condition |
| commands | commands to repeat |
This is a dummy implementation, which is not used except for reserving a unique address for WHILE primitive.
| commands | commands to repeat |
| condition | repetition condition |
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 | ||
| ) |
{
| condition | repetition condition |
| commands | commands to repeat |
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 | ||
| ) |
| commands | commands to repeat |
| condition | repetition condition |
This is a dummy implementation, which is not used except for reserving a unique address for DO.UNTIL primitive.
{
| data | value to check |
| source | source of the expression |
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 | ||
| ) |
| frame | base frame pointer |
| count | number 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.
| atom_t rt_repeat_exit | ( | int | frame | ) |
| frame | base frame pointer |
This function removes the top-most repeat-node and returns unbound atom.
| atom_t rt_repcount | ( | int | frame | ) |
| frame | base frame pointer |
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 | ) |
| commands | commands to repeat |
This is a dummy implementation, which is not used except for reserving a unique address for FOREVER primitive.
{
| void rt_forever_enter | ( | int | frame | ) |
| frame | base 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.
| data | data to parse |
Implements primitive function PARSE. Returns the input parsed as data.
{
| atom_t rt_runparse | ( | atom_t | data | ) |
| data | data to parse |
Implements primitive function RUNPARSE. Returns the input parsed as commands.
{
| data | data to test |
true if data is word or false if is notImplements 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] ) );
}
//===================================================
| data | data to test |
true if data is list or false if is notImplements primitive predicate LISTP. Returns true if argument is list or false if it is not
{
| atom_t rt_numberp | ( | atom_t | data | ) |
| data | data to test |
true if data is number or false if is notImplements 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] ) );
}
//===================================================
| data | data to test |
true if data is empty or false if is notImplements 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 | ||
| ) |
| cip | value of CASEIGNOREDP |
| data | Data where will search |
| elem | Element which will be searched |
true if elem is in data or false if is notImplements 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] ) );
}
}
//===================================================
| data | number of inputs of WORD |
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 );
}
//===================================================
| data | number of inputs of LIST |
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.
| data | number of inputs of SE |
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 );
}
//===================================================
| data1 | Element to add |
| data2 | List or word |
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 );
}
}
//===================================================
| data1 | Element to add |
| data2 | List or word |
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 );
}
}
//===================================================
| data | Atom to inspect |
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 ) );
}
//===================================================
| data | ASCII code |
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 ) );
}
//===================================================
| data | one char word |
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 ) );
}
//===================================================
| data | word |
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 );
}
//===================================================
| data | word |
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 );
}
//===================================================
| cip | value of CASEIGNOREDP |
| data | Data where will search |
| elem | Element which will be searched |
data form first occurence of elem to the endImplements 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 ) );
}
}
//===================================================
| from | First element of the sequence |
| to | Last element of the sequence |
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 );
}
//===================================================
| from | First element of the sequence |
| to | Last element of the sequence |
| count | Number of elements in the sequence |
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 );
}
//===================================================
| count | number of arguments (1 or 2) |
| data1 | first argument |
| data2 | second argument |
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 | ||
| ) |
| count | number of arguments (0 or 1) |
| seed | number to set random seed |
Implements the primitive RERANDOM. Makes the results of RANDOM reproducible.
| pdl | value of PRINTDEPTHLIMIT |
| pwl | value of PRINTWIDTHLIMIT |
| fpp | value of FULLPRINTP |
| data | number 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 );
}
//===================================================
| pdl | value of PRINTDEPTHLIMIT |
| pwl | value of PRINTWIDTHLIMIT |
| fpp | value of FULLPRINTP |
| data | number 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.
| num | number to be converted |
| width | width in wich number will be printed |
| precision | precision with wich number will be printed |
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 | ) |
| string | a format string |
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;
}
//===================================================
| data | data to be formated |
| format | formating 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 | ||
| ) |
| data | data to be formated |
| format | formating 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 | ||
| ) |
| data | data to test |
| static_link | static link from the current frame |
| parent | current parent |
true if data contains the name of a user-defined functionImplements 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 | ||
| ) |
| data | data to test |
| static_link | static link from the current frame |
| parent | current parent |
true if data contains the name of a primitive functionImplements primitive predicate PRIMiTIVE?. Returns true if data contains the name of a primitive function or command.
{
| data | data to test |
| static_link | static link from the current frame |
| parent | current parent |
true if data contains the name of a variableImplements 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 | ||
| ) |
| data | data to test |
| static_link | static link from the current frame |
| parent | current parent |
true if data contains the name of a function or a commandImplements 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 | ||
| ) |
| var | the variable |
| static_link | static link from the current frame |
| parent | current parent |
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 | ||
| ) |
| source | the source code |
| value | the variable's value |
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.
{
| static_link | static link from the current frame |
| parent | current parent |
| data | variable 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 | ||
| ) |
| data | variable name |
| static_link | static link from the current frame |
| parent | current parent |
Implements the : syntax. Returns the value of the variable which name is following the colons. If there is no variable, then return error atom.
| time | Time 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 );
}
//===================================================
| bits | Number of bits to shift |
| num | Number to be shifted |
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 ) );
}
}
//===================================================
| bits | Number of bits to shift |
| num | Number to be shifted |
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 ) );
}
}
//===================================================
| data | number of inputs of BITAND |
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 ) );
}
//===================================================
| data | number of inputs of BITOR |
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 ) );
}
//===================================================
| data | number of inputs of BITXOR |
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 ) );
}
//===================================================
| data | integer number. |
Implement binary operation BITNOT. The only input contains the number to be negated. Returns its binary negation (NOT)
{
| list | a 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 ) );
}
//===================================================
| cip | value of CASEIGNOREDP |
| data | a list or a word |
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);
}
//===================================================
| cip | value of CASEIGNOREDP |
| data | a list or word |
| elem | an atom to be remowed from list or char to be removed from word |
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);
}
//===================================================
| atom_t rt_reverse | ( | atom_t | data | ) |
| data | a list or a word |
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 );
}
//===================================================
| atom_t rt_rawascii | ( | atom_t | data | ) |
| data | one char word |
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 ) );
}
//===================================================
Implements the primitive GENSYM. Returns unique word each time it's called The words are like that G1, G2, G3...
| atom_t rt_substringp | ( | atom_t | cip, |
| atom_t | data2, | ||
| atom_t | data1 | ||
| ) |
| cip | value of CASEIGNOREDP |
| data1 | String to be search |
| data2 | String to search in |
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 | ||
| ) |
| cip | value of CASEIGNOREDP |
| data1 | String to be search |
| data2 | String to search in |
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 | ||
| ) |
| data1 | Element to add |
| data2 | List or word |
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 );
}
//===================================================
| data | Element to quote |
Implements the primitive QUOTED. Returns data if it's a list or data with quotation if is a word.
{
| count | number of arguments (1 or 2) |
| data1 | first parameter of THROW |
| data2 | second parameter of THROW |
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 );
}
//===================================================
| commands | commands monitored by catch |
| tag | catch tag |
Dummy implementation of primitive CATCH.
{
| atom_t rt_catchchk | ( | int | status, |
| atom_t | tag, | ||
| atom_t | data | ||
| ) |
| status | output status of data |
| tag | catch's tag |
| data | value to check |
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;
}
//===================================================
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 );
}
//===================================================
| static_link | static link from the current frame |
| parent | current parent |
| data | name of variable |
| source | source of GOTO |
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.
{
| commands | commands to run |
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 | ) |
| commands | commands to run |
This is a dummy implementation, which is not used except for reserving a unique address for IFFALSE primitive.
{
| frame | base frame pointer |
| condition | condition to store |
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.
{
| atom_t rt_backslashedp | ( | atom_t | data | ) |
| data | one char word |
true if data contains backslashed characterImplements the primitive BACLSLASHED?.
{
RETURN( new_error( ERROR_INCOMPATIBLE_DATA, data ) );
}
char_t ch = *STRING( data );
DEUSE( data );
RETURN( USE( false_true[ch != DEBAR( ch )] ) );
}
//===================================================
| data | function name |
| static_link | static link from the current frame |
| parent | current parent |
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 | ||
| ) |
| data | function name |
| static_link | static link from the current frame |
| parent | current parent |
Implements primitive FULLTEXT. Returns a word containing the function as source. If the source is not avaialble, then return the same result as TEXT.
{
| data | data to run |
| static_link | static link from the current frame |
| parent | current parent |
| mode | COMPILE_AS_FUNC or COMPILE_AS_PROC |
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 | ||
| ) |
| data | data to run |
| static_link | static link from the current frame |
| parent | current parent |
| mode | COMPILE_AS_FUNC or COMPILE_AS_PROC |
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.
| atom_t rt_runresult | ( | int | static_link, |
| atom_t | parent, | ||
| atom_t | data | ||
| ) |
| data | data to run |
| static_link | static link from the current frame |
| parent | current parent |
Implements primitive command/function RUNRESULT by reusing rt_run() function.
{
| atom_t rt_runresult_fix | ( | atom_t | data | ) |
| data | data to fix |
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.
{
| static_link | static link from the current frame |
| parent | current parent |
| name | name of function |
| value | body 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;
}
//===================================================
| body | body of FOR command |
| limits | list of initial and final limits |
| var | name of control variable |
This is a dummy implementation, which is not used except for reserving a unique address for FOR primitive.
{
| atom_t rt_libload | ( | atom_t | data | ) |
| data | filename of the dynamic library |
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 );
}
//===================================================
| atom_t rt_libfree | ( | atom_t | data | ) |
| data | handle of the dynamic library |
Implements the primitive LIBFREE.
{
| atom_t rt_blocksize | ( | int | static_link, |
| atom_t | parent, | ||
| atom_t | prototype | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| prototype | pack prototype |
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.
| atom_t rt_listtoblock | ( | int | static_link, |
| atom_t | parent, | ||
| atom_t | prototype, | ||
| atom_t | data | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| data | data to pack |
| prototype | pack prototype |
Implements primitive LISTTOBLOCK. Creates a memory atom big enough to hold all packed data.
| atom_t rt_blocktolist | ( | int | static_link, |
| atom_t | parent, | ||
| atom_t | prototype, | ||
| atom_t | data | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| data | data to unpack |
| prototype | pack prototype |
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;
}
//===================================================
| atom_t rt_dataaddr | ( | atom_t | data | ) |
| data | atom which address is returned |
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 | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| dest | destination for packed data |
| prototype | pack prototype |
| data | data to pack |
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 | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| data | function 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.
{
| static_link | static link from the current frame |
| parent | current parent |
| handle | handle of library |
| prototype | external function prototype |
| name | function to externalize |
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 | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| prototype | internal function prototype |
| name | function to internalize |
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 | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| offset | offset in the stack frame |
| frame | stack frame number |
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 | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| offset | offset in the stack frame |
| frame | stack frame number |
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.
{
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.
| data | name of file to load |
Implements primitive command LOAD. Creates a local function with the given body, compiles it, and
{
| atom_t rt_commandline | ( | ) |
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 | ||
| ) |
| mode | open mode (read, write, ...) |
| filename | name of binary file |
| call_mode | COMPILE_AS_FUNC or COMPILE_AS_PROC |
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 | ||
| ) |
| mode | open mode (read, write, ...) |
| filename | name of binary file |
| call_mode | COMPILE_AS_FUNC or COMPILE_AS_PROC |
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 | ||
| ) |
| file | file handle or file name |
| index | variable to store the index |
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 );
};
//===================================================
| atom_t rt_closefile | ( | atom_t | file | ) |
| file | file to close |
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 | ||
| ) |
| static_link | static link from the current frame |
| parent | current parent |
| size | size of the block and number of bytes to read |
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 | ||
| ) |
| block | block to read data to |
| call_mode | COMPILE_AS_FUNC or COMPILE_AS_PROC |
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 ); }
};
//===================================================
| atom_t rt_writeblock | ( | atom_t | data | ) |
| data | packed data to be written |
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 );
};
//===================================================
| atom_t rt_readchar | ( | void | ) |
| atom_t rt_readchars | ( | atom_t | data | ) |
| data | number of characters to read |
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 );
}
//===================================================
| atom_t rt_readrawline | ( | void | ) |
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;
}
//===================================================
| atom_t rt_readword | ( | void | ) |
Implements the primitive function readword. Reads a single line from the read stream and outputs that line as a word. Processes backslashes, vertical bars.
{
| atom_t rt_readlist | ( | void | ) |
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 ";".
{
| data | environment variable name |
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 );
}
//===================================================
| atom_t rt_getenvs | ( | ) |
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 );
}
//===================================================
Implements the primitive function eof?. Outputs true if there are no more characters to be read, or false otherwise.
{
Implements the primitive function currentfolder. Outputs a word atom containing the name of the current folder.
{
| atom_t rt_makefolder | ( | atom_t | name | ) |
| name | name of a folder to make |
Implements the primitive function makefolder. Create a folder with given name relative to the current folder. Outputs unbound or error atom.
{
| atom_t rt_erasefolder | ( | atom_t | name | ) |
| name | name of a folder to erase |
Implements the primitive function erasefolder. Erases an empty folder with given name relative to the current folder. Outputs unbound or error atom.
{
| atom_t rt_changefolder | ( | atom_t | name | ) |
| name | name of a folder to change to |
Implements the primitive function changefolder. Changes the current folder to a given folder. Outputs unbound or error atom.
{
| atom_t rt_folderp | ( | atom_t | name | ) |
| name | name of a folder to test |
Implements the primitive function folder?. Returns "true if a folder with the given name
exists. Otherwise return "false.
| atom_t rt_renamefolder_or_file | ( | atom_t | toname, |
| atom_t | fromname, | ||
| int | folders | ||
| ) |
| toname | new name of a folder |
| fromname | old name of a folder |
| folders | if !=0, rename a folder, otherwise a file |
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 | ||
| ) |
| toname | new name of a folder |
| fromname | old name of a folder |
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 | ||
| ) |
| toname | new name of a file |
| fromname | old name of a file |
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 | ||
| ) |
| name | name of a folder to scan |
| folders | if !=0, scans for folders, otherwise for files |
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 );
}
//===================================================
| atom_t rt_folders | ( | atom_t | name | ) |
| name | name of a folder to list |
Implements the primitive function folders. Returns a list of folders' names in a given folder.
{
| name | name of a folder to list |
Implements the primitive function files. Returns a list of files' names in a given folder.
{
| atom_t rt_erasefile | ( | atom_t | name | ) |
| name | name of a file to erase |
Implements the primitive function erasefile. Erases a file with given name relative to the current folder. Outputs unbound or error atom.
{
| name | name/path of a file to test |
Implements the primitive function file?. Returns "true if a file with the given name
or path exists. Otherwise return "false.
| atom_t rt_filesize | ( | atom_t | name | ) |
| name | name of a file |
Implements the primitive function filesize. Returns size of the file in bytes if the file exists. Otherwise returns -1.
{
| atom_t rt_filetimes | ( | atom_t | name | ) |
| name | name of a file |
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 | ||
| ) |
| name | name of a file |
| call_mode | COMPILE_AS_FUNC or COMPILE_AS_PROC |
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 | ||
| ) |
| name | name of a file |
| call_mode | COMPILE_AS_FUNC or COMPILE_AS_PROC |
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 | ||
| ) |
| name | name of a file |
| call_mode | COMPILE_AS_FUNC or COMPILE_AS_PROC |
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 | ||
| ) |
| name | name of a file |
| call_mode | COMPILE_AS_FUNC or COMPILE_AS_PROC |
Implements the primitive function o/c/te. Returns an integer atom with the file handle or an error atom.
{
| atom_t rt_setread | ( | atom_t | file | ) |
| file | file to set as a reader |
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 );
};
//===================================================
| atom_t rt_setwrite | ( | atom_t | file | ) |
| file | file to set as a writer |
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 );
};
//===================================================
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 );
};
//===================================================
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 );
};
//===================================================
| atom_t rt_allopen | ( | ) |
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 );
};
//===================================================
| atom_t rt_closeall | ( | ) |
Implements primitive command CLOSEALL. Closes all opened files, returns unbound atom.
{
| atom_t rt_setreadpos | ( | atom_t | pos | ) |
| pos | file position for the reader |
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 );
};
//===================================================
| atom_t rt_readpos | ( | ) |
Implements primitive command READPOS. Returns the reading position of the reader (i.e. input stream).
{
| atom_t rt_setwritepos | ( | atom_t | pos | ) |
| pos | file position for the writer |
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.
{
| atom_t rt_writepos | ( | ) |
Implements primitive command WRITEPOS. Returns the writinging position of the writer (i.e. output stream).
{
| atom_t rt_timezone | ( | ) |
Implements primitive function TIEMZONE. Returns the timezone difference with GMT in seconds.
| char* file_names[FOPEN_MAX] = { [0 ... (FOPEN_MAX-1)]=NULL } |
| FILE* file_handles[FOPEN_MAX] = { [0 ... (FOPEN_MAX-1)]=NULL } |