Lhogho  0.0.028
 All Data Structures Files Functions Variables Typedefs Macros Pages
runtime.c
Go to the documentation of this file.
1 //
2 // Project: Lhogho
3 // File: runtime.c
4 //
5 // Copyright (C) 2007-2012 P.Boytchev
6 //
7 // Revision history:
8 // 2007-06-19 - file created
9 // 2007-06-25 - rt_plus()
10 // 2007-06-26 - rt_minus(), rt_mul(), rt_div()
11 // 2007-07-04 - rt_cmdchk(), rt_funchk()
12 // 2007-07-06 - fixed bug #1748684 Memory leak print (45-10)*(10 + (1+"abc)*(3-4))
13 // 2007-07-31 - rt_make()
14 // - fixed bug #1764281 Wrong error message
15 // 2007-08-01 - rt_local()
16 // 2007-08-05 - rt_makechk()
17 // 2007-08-07 - fixed bug #1769316 Memory leak of 1 atom in MAKE
18 // 2007-08-08 - Added implementations of arithmetical and trigonometric primitives
19 // 2007-08-10 - Fixed bug #1771145 - Trigonometrical functions precision problem
20 // 2007-08-10 - Handle of invalid values for arithmetic functions
21 // 2007-08-13 - support for PRINTDEPTHLIMIT, PRINTWIDTHLIMIT
22 // 2007-09-03 - Fixed bug #1787023 ARCTAN and RADARCTAN
23 // 2007-09-15 - Added implementations of comparison primitives
24 // 2007-09-17 - Added support for AND, OR, NOT
25 // 2007-09-18 - rt_output(), rt_stop(), rt_dump()
26 // 2007-09-19 - Fixing doxygen coments due to bugs #1797861 and #1797054
27 // 2007-09-19 - rt_ignore()
28 // 2007-09-19 - rt_first(), rt_butfirst()
29 // 2007-09-19 - rt_last(), rt_butlast(), rt_item()
30 // Many fixes and optimizations on previously implemented functions
31 // 2007-09-23 - Support for IF
32 // - Support for PARSE, RUNPARSE
33 // 2007-09-26 - Fixed bug #1800491 Memory leak in if-nested.lgo
34 // - Fixed bug #1800961 Memory leak in 14=10
35 // 2007-09-26 - rt_numberp(), rt_wordp(), rt_listp(), rt_empty()
36 // 2007-09-27 - rt_memberp()
37 // 2007-09-29 - rt_repeat()
38 // 2007-10-06 - rt_word(), rt_list(), rt_sent(), rt_lput(), rt_fput()
39 // 2007-10-13 - rt_count(), rt_char(), rt_ascii(), rt_upper(), rt_lower(), rt_member()
40 // 2007-10-16 - Fixed bug #1814279 Errors masked by IGNORE
41 // 2007-10-21 - rt_repchk(), rt_forever()
42 // 2007-10-21 - Fixed bug #1817321
43 // 2007-10-23 - rt_repcount()
44 // 2007-10-28 - rt_random(), rt_rerandom(), rt_iseq(), rt_rseq()
45 // 2007-10-28 - implement #1815125
46 // 2007-10-28 - rt_type(), rt_show(), rt_form(), rt_format()
47 // 2007-11-03 - Fixed bug #1821537 repeat cause compiler crash
48 // 2007-11-04 - rt_while(), rt_until()
49 // - Fixed bug #1825647 Various warning in dev doc
50 // 2007-11-05 - support for PRINTDEPTHLIMIT, PRINTWIDTHLIMIT and
51 // FULLPRINTP
52 // 2007-11-06 - rt_dowhile(), rt_dountil()
53 // - rt_definedp(), rt_primitivep(), rt_name(),
54 // - rt_procedurep(), rt_thing()
55 // 2007-11-09 - Fixed bug #1828216 MAKE with expression for var name
56 // - Fixed bug #1828215 MAKE does not work with unknown variables
57 // - Fixed bug #1828217 ':' does not work with unknown variables
58 // 2007-11-10 - Fixed bug #1828116 Warning compiling get_format()
59 // 2007-11-11 - Support for WAIT and BYE
60 // - Support for NAME
61 // 2007-11-12 - Support for THROW
62 // - rt_before optimized not to copy buffers if they are words.
63 // 2007-11-16 - rt_catch()
64 // 2007-11-17 - Fixed bug #1832660 THROW <tag> not implemented
65 // 2007-11-18 - Fixed bug #1833771 Test case catch-08.lgo fails
66 // 2007-11-19 - Support for TAG, GOTO
67 // 2007-11-21 - rt_test()
68 // 2007-11-22 - rt_iftrue(), rt_iffalse()
69 // 2007-12-02 - Fixed bugs #1838919, #1838911, #1838910, #1838909,
70 // #1838908, #1838907, #1838906 and #1831028
71 // - rt_backslashedp()
72 // 2007-12-02 - Implemented featutre request #1842653 - DEBAR
73 // - Support for ASHIFT, LSHIFT
74 // - Support for BITAND, BITOR, BITXOR, BITNOT
75 // 2007-12-03 - rt_text()
76 // 2007-12-14 - rt_fulltext()
77 // 2007-12-15 - Fixed bug #1832680 - wrong error message in fput and lput
78 // 2007-12-16 - Support for PICK, REMDUP, REMOVE, REVERSE,
79 // RAWASCII, GENSYM, SUBSTRINGP
80 // 2007-12-30 - Support for COMBINE
81 // 2008-01-07 - Fixed bug #1856864 Defined but unset variables
82 // - Support for RUNRESULT
83 // 2008-03-22 - Support for QUOTED
84 // 2008-04-28 - Fixed bug #1952921 FPUT does not work with numbers
85 // Fixed bug #1953190 ASCII.LGO and RAWASCII.LGO fail
86 // Fixed bug #1953207 In Fedora 4 tests fail
87 // 2008-07-19 - Changed depricated _sleep() to Win32API's Sleep()
88 // 2008-08-17 - rt_firsts(), rt_butfirsts()
89 // 2008-08-23 - Support for FOR
90 // 2008-09-05 - Support for LIBLOAD, LIBFREE
91 // - Support for PACKSIZE, PACK, UNPACK
92 // 2008-09-06 - Support for PACKADDR, PACKTO
93 // 2008-09-09 - Support for EXTERNAL
94 // 2008-10-27 - Support for LOAD
95 // 2008-11-21 - rt_packopen(), rt_packclose(), rt_packread(), rt_packwrite()
96 // 2009-03-12 - Implementer request 2544111 - extend REVERSE
97 // 2009-05-16 - rt_abs()
98 // 2009-06-03 - rt_readchar(), rt_readchars(), rt_getenv(), rt_getenvs()
99 // 2009-07-28 - Implementer request 2776194 - extend REMDUP and REMOVE
100 // 2009-08-02 - Fixed bug #2794985 CALHC fails with wrong input
101 // 2009-08-03 - Support for READRAWLINE
102 // 2009-08-03 - Support for READWORD
103 // 2009-08-16 - Fixed bug #2838617 RUN suppresses STOP
104 // 2009-08-19 - Support for MAYBEOUTPUT
105 // 2009-08-20 - Support for _STACKFRAME, _STACKFRAMEATOM
106 // 2009-08-29 - Fixed bug #2845099 Memory leak in THROW
107 // - Fixed bug #2845579 DEBUG_MEMORY_LEAKS finds two bad tests
108 // - Fixed bug #2846281 Errors not (de)used correctly
109 // 2009-08-30 - Fixed bug #2847273 Crash of prematurely cleared errors
110 // 2009-09-01 - Fixed bug #2847596 Error in NAME?
111 // 2010-06-25 - Support for EOF?
112 // 2010-06-26 - Fixed bug #3021674 GETENVS fails when executed multiple times
113 // 2011-02-05 - Fixed bug #3173377 Warnings building developer's documentation
114 // - Renamed file functions
115 // 2011-02-28 - Fixed bug #3195266 Assertion at atoms.c:310 failed
116 // 2011-03-03 - Fixed bug #3198402 Test cases fail to comply with the new memory test
117 // 2011-10-14 - Support for RUNMACRO
118 // 2011-10-22 - Fixed bug #3427251 Indirect MAKE and LOCAL cause a crash
119 // 2011-11-30 - Fixed bug #3445230 Catch doesn't catch an error
120 // 2011-12-01 - Fixed bug #3442800 Going beyond the end limit of FOR
121 // 2011-12-25 - Fixed bug #3463989 remainder 1 0 generates assertion error
122 // 2011-12-26 - Support for SUBSTRING
123 // 2012-01-02 - Command-line options are translatable
124 // 2012-01-15 - Fixed bug #3474182 Error in packs causes out of memory in Linux
125 // 2012-01-19 - Support for CURRENTFOLDER, MAKEFOLDER
126 // 2012-01-20 - Support for ERASEFOLDER, FOLDER?, FOLDERP
127 // 2012-01-21 - Support for FOLDERS, CHANGEFOLDER
128 // 2012-01-23 - Support for FILES, ERASEFILE, FILE?, FILEP, RENAMEFILE
129 // FILESIZE, FILETIMES, FORMATTIME
130 // 2012-01-24 - Support for OPENREAD, OPENWRITE, OPENAPPEND, OPENUPDATE
131 // SETREAD, SETWRITE
132 // 2012-01-25 - init_runtime(), finit_runtime(), find_file_by_name()
133 // find_file_by_handle()
134 // - Support for READER, WRITER, ALLOPEN
135 // 2012-01-27 - Support for CLOSEALL, READPOS, SETREADPOS, WRITEPOS, SETWRITEPOS
136 // 2012-01-31 - Support for TIMEZONE
137 // 2012-02-02 - Fixed bug #3482718 Closing file with invalid handle causes a crash
138 // 2012-02-04 - READPACK/WRITEPACK use file set by SETREAD/SETWRITE
139 // Fixed bug #3484310 Wrong error when unpacking empty list
140 // Fixed bug #3484326 SETWRITE [] causes crash
141 // Fixed bug #3484297 Crash if error in readpack
142 // Fixed bug #3484289 Open non-existing file for reading - no error
143 // 2012-02-05 - Renamed READPACK->READBLOCK, WRITEPACK->WRITEBLOCK, PACKADDR->DATAADDR
144 // PACKSIZE->BLOCKSIZE, PACK->LISTTOBLOCK, UNPACK->BLOCKTOLIST,
145 // PACKTO->LISTINTOBLOCK
146 // - Support for READINBLOCK
147 // 2012-02-09 - Support for DRIBBLE, NODRIBBLE
148 // 2012-02-26 - Fixed bug #3493871 Externals do not capture errors
149 // 2012-02-27 - Fixed bug #3494907 Errors in user function inputs cause assertion fail
150 // 2013-07-04 - If rt_libload() fails, it tries in lib subfolder of the compiler
151 //
152 //
153 // This program is free software; you can redistribute it and/or modify
154 // it under the terms of the GNU General Public License as published by
155 // the Free Software Foundation; either version 2 of the License, or
156 // (at your option) any later version.
157 //
158 // This program is distributed in the hope that it will be useful,
159 // but WITHOUT ANY WARRANTY; without even the implied warranty of
160 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
161 // GNU General Public License for more details.
162 //
163 // You should have received a copy of the GNU General Public License
164 // along with this program; if not, write to the Free Software
165 // Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
166 //
167 
168 
169 #include <stdio.h>
170 #include <math.h>
171 #include <limits.h>
172 #include <assert.h>
173 #include <stdlib.h> // rand, srand
174 #include <unistd.h> // usleep, getcwd, ...
175 #include <errno.h> // EIO
176 #include <sys/stat.h> // stat, S_ISDIR, ...
177 #include <sys/types.h>
178 #include <dirent.h>
179 #include <time.h> // localtime_r
180 #include <limits.h> // PATH_MAX
181 #include <libgen.h> // dirname()
182 
183 #ifdef WINDOWS
184 #include <windows.h>
185 #include <mmsystem.h>
186 #undef TEXT
187 #undef IS_ERROR
188 #define dlopen(a,b) LoadLibrary(a)
189 #define dlclose(a) FreeLibrary(a)
190 #define dlsym(h,a) GetProcAddress(h,a)
191 #else
192 #include <dlfcn.h>
193 #endif
194 
195 #include "globals.h"
196 #ifdef UNICODE_CHARS
197 #include <wctype.h>
198 #include <wchar.h> // STRCHR (i.e. wcsstr)
199 #endif
200 
201 #include "atoms.h"
202 #include "lists.h"
203 #include "words.h"
204 #include "numbers.h"
205 #include "vars.h"
206 #include "unicode.h"
207 #include "parser.h"
208 #include "errors.h"
209 #include "options.h"
210 #include "parser.h"
211 #include "compiler.h"
212 #include "mems.h"
213 #include "external.h"
214 #include "runtime.h"
215 
216 
217 #define test_elem_and_destroy_if_error(elem, list) \
218  { \
219  if (IS_ERROR(elem)) \
220  { \
221  DEUSE (list); \
222  RETURN (elem); \
223  } \
224  }
225 
226 
227 #define ARGUMENT *pdata
228 #define EACH_ARGUMENT pdata=(atom_t*)(&data+data); (int*)pdata>&data; pdata--
229 
230 
231 #define SIGN(X) \
232  ((X == 0) ? 0 : (X < 0 ? -1 : 1))
233 
235 #define ZERO_PRECISION 1e-10
236 #define MAX_NUMBER_WORD_LENGTH 64
237 #define MAX_WORD_LENGTH 4096
239 #define CHECK_PARAM(param) if( IS_ERROR(param) ) RETURN(USE(param))
240 
241 #undef RUNTIME
242 #define RUNTIME __attribute__((used,noinline,regparm(0),cdecl))
244 char* file_names[FOPEN_MAX] = { [0 ... (FOPEN_MAX-1)]=NULL };
245 FILE* file_handles[FOPEN_MAX] = { [0 ... (FOPEN_MAX-1)]=NULL };
247 void rt_set_var_value( int static_link, atom_t parent, atom_t var, atom_t value );
248 
250 //===================================================
255 //===================================================
256 void init_runtime( )
257 {
258  srand(time(0));
259 }
260 
261 
262 
264 //===================================================
270 //===================================================
271 void finit_runtime( )
272 {
273  rt_closeall();
274  rt_nodribble();
275 }
276 
277 
279 //===================================================
288 //===================================================
289 int find_file_by_filename (char* filename)
290 {
291  int i;
292 
293  for( i=0; i<FOPEN_MAX; i++ )
294  if( file_names[i] )
295  if( strcmp(file_names[i],filename)==0 ) // string are ASCII/UTF8
296  return i;
297  return -1;
298 }
299 
300 //===================================================
309 //===================================================
310 int find_file_by_handle (FILE* handle)
311 {
312  int i;
313  for( i=0; i<FOPEN_MAX; i++ )
314  if( file_handles[i]==handle )
315  return i;
316  return -1;
317 }
318 
319 
320 
321 
322 //===================================================
335 //===================================================
336 #define rt_makechk __attribute__((used,noinline,regparm(0),stdcall)) rt_makechk
337 
338 atom_t rt_makechk( atom_t source, atom_t data )
339 #undef rt_makechk
340 {
341  #ifdef SAFEMODE
342  assert( data );
343  #endif //SAFEMODE
344 
345  //printf("---------------\n");
346  //printf("inside rt_makechk\n");
347  //printf(" - source="); dumpln(source);
348  //printf(" - data ="); dumpln(data);
349  //printf("---------------\n");
350 
351 #ifdef ADVANCED
352  if (OPTION_RUNTIME)
353  {
354  outter( TEXT( "DONE " ), -1 );
355  dumpln( source );
356  }
357 #endif
358 
359  if (IS_UNBOUND( data ))
360  {
361  return new_error( ERROR_MISSING_VALUE, source );
362  }
363 
364  if (IS_ERROR( data ))
365  {
366  add_error_source( data, source );
367  return USE( data );
368  }
369 
370  // this unbound should not be USE()'d, because
371  // it is used only for checking -- it is not
372  // stored anywhere
373  return unbound;
374 }
375 
376 
377 
378 
379 //===================================================
392 //===================================================
393 #define rt_cmdchk __attribute__((used,noinline,regparm(0),stdcall)) rt_cmdchk
394 
395 atom_t rt_cmdchk( atom_t source, atom_t data )
396 #undef rt_cmdchk
397 {
398  #ifdef SAFEMODE
399  assert( data );
400  #endif //SAFEMODE
401 
402  //printf("---------------\n");
403  //printf("inside rt_cmdchk\n");
404  //printf(" - source="); dumpln(source);
405  //printf(" - datax =%x\n",(int)data);
406  //printf(" - data ="); dumpln(data);
407  //printf("---------------\n");
408 
409 #ifdef ADVANCED
410  if (OPTION_RUNTIME)
411  {
412  outter( TEXT( "DONE " ), -1 );
413  dumpln( source );
414  }
415 #endif
416  if (IS_UNBOUND( data ) || IS_STOPPED( data ))
417  return data;
418 
419  if (IS_ERROR( data ))
420  {
421  add_error_source( data, source );
422  return USE( data );
423  }
424 
425  DEUSE( data );
426  return new_error( ERROR_UNUSED_VALUE, source );
427 }
428 
429 
430 
431 
432 //===================================================
443 //===================================================
444 #define rt_exprchk __attribute__((used,noinline,regparm(0),stdcall)) rt_exprchk
445 
446 atom_t rt_exprchk( atom_t source, atom_t data )
447 #undef rt_exprchk
448 {
449  #ifdef SAFEMODE
450  assert( data );
451  #endif //SAFEMODE
452 
453  //printf("---------------\n");
454  //printf("inside rt_exprchk\n");
455  //printf(" - source="); dumpln(source);
456  //printf(" - data ="); dumpln(data);
457  //printf("---------------\n");
458 
459 #ifdef ADVANCED
460  if (OPTION_RUNTIME)
461  {
462  outter( TEXT( "DONE " ), -1 );
463  dumpln( source );
464  }
465 #endif
466 
467  if (IS_ERROR( data ))
468  {
469  add_error_source( USE( data ), source );
470  }
471 
472  return data;
473 }
474 
475 
476 
477 
478 //===================================================
487 //===================================================
488 #define rt_boolchk __attribute__((used,noinline,regparm(0),stdcall)) rt_boolchk
489 
490 atom_t rt_boolchk( atom_t source, atom_t data )
491 #undef rt_boolchk
492 {
493  #ifdef SAFEMODE
494  assert( data );
495  #endif //SAFEMODE
496 
497  if (IS_ERROR( data ))
498  {
499  add_error_source( data, source );
500  return USE( data );
501  }
502 
503  int b;
504  if (atom_to_boolean( data, &b ))
505  {
506  DEUSE( data );
507  return ( false_true[b]);
508  }
509 
510  DEUSE( data );
511  return new_error( ERROR_BOOLEAN_EXPECTED, source );
512 }
513 
514 
515 
516 
517 //===================================================
530 //===================================================
531 #define rt_funchk __attribute__((used,noinline,regparm(0),stdcall)) rt_funchk
532 
533 atom_t rt_funchk( atom_t source, atom_t data )
534 #undef rt_funchk
535 {
536  #ifdef SAFEMODE
537  assert( data );
538  #endif //SAFEMODE
539 
540  //printf("---------------\n");
541  //printf("inside rt_funchk\n");
542  //printf(" - source="); dumpln(source);
543  //printf(" - data ="); dumpln(data);
544  //printf("---------------\n");
545 
546 #ifdef ADVANCED
547  if (OPTION_RUNTIME)
548  {
549  outter( TEXT( "EVAL " ), -1 );
550  dump( source );
551  outter( TEXT( " = " ), 3 );
552  dumpln( data );
553  }
554 #endif
555 
556  if (IS_ERROR( data ))
557  {
558  add_error_source( data, source );
559  return ( USE(data) );
560  }
561 
562  if (!IS_UNBOUND( data ))
563  return data;
564 
565 
566  DEUSE( data );
567  return new_error( ERROR_MISSING_VALUE, source );
568 }
569 
570 
571 
572 
573 //===================================================
587 //===================================================
588 #define rt_repchk __attribute__((used,noinline,regparm(0),stdcall)) rt_repchk
589 
590 atom_t rt_repchk( atom_t source, atom_t data )
591 #undef rt_repchk
592 {
593  #ifdef SAFEMODE
594  assert( data );
595  #endif //SAFEMODE
596 
597  //printf("data=%x\n",data);
598  //printf("atom type=%d\n",ID(data));
599  //printf("repeat atom="); dumpln(data);
600 
601  if (IS_ERROR( data ))
602  {
603  add_error_source( data, source );
604  return USE( data );
605  }
606 
607  if (IS_UNBOUND( data ))
608  {
609  DEUSE( data );
610  return new_error( ERROR_MISSING_VALUE, source );
611  }
612 
613  int64_t cnt;
614  if (!atom_to_int( data, &cnt ))
615  {
616  DEUSE( data );
617  return new_error( ERROR_NOT_AN_INTEGER, source );
618  }
619 
620  DEUSE( data );
621 
622  if (cnt > INT_MAX)
623  return new_error( ERROR_TOO_BIG_NUMBER, source );
624 
625  if (cnt < 0)
626  return new_error( ERROR_TOO_SMALL_NUMBER, source );
627 
628  return new_integer( cnt );
629 }
630 
631 
632 
633 
634 //===================================================
651 //===================================================
652 #define rt_forchk __attribute__((used,noinline,regparm(0),stdcall)) rt_forchk
653 
654 atom_t rt_forchk( atom_t source, atom_t* step_value, atom_t step, atom_t to, atom_t from )
655 #undef rt_forchk
656 {
657  float64_t from_f;
658  float64_t to_f;
659  float64_t step_f;
660 
661  //printf("---<<< RT_FOR_CHK >>>---\n");
662  //printf(" source="); dumpln(source);
663  //printf(" from="); dumpln(from);
664  //printf(" to="); dumpln(to);
665  //printf(" step="); dumpln(step);
666  //printf(" value="); dumpln(*step_value);
667 
668  // process the initial value
669  if (IS_ERROR( from ))
670  {
671  DEUSE( to );
672  DEUSE( step );
673  add_error_source( from, source );
674  return USE( from );
675  }
676 
677  if (IS_UNBOUND( from ))
678  {
679  //DEUSE( from ); /// ???
680  DEUSE( to );
681  DEUSE( step );
682  return new_error( ERROR_MISSING_VALUE, source );
683  }
684 
685  if (!atom_to_float( from, &from_f ))
686  {
687  //DEUSE( from );
688  DEUSE( to );
689  DEUSE( step );
690  return new_error( ERROR_NOT_A_NUMBER, source );
691  }
692 
693 
694  // process the final value
695  if (IS_ERROR( to ))
696  {
697  DEUSE( from );
698  DEUSE( step );
699  add_error_source( to, CDR( source ) );
700  return USE( to );
701  }
702 
703  if (IS_UNBOUND( to ))
704  {
705  DEUSE( from );
706  //DEUSE( to );
707  DEUSE( step );
708  return new_error( ERROR_MISSING_VALUE, CDR( source ) );
709  }
710 
711  if (!atom_to_float( to, &to_f ))
712  {
713  //DEUSE( from );
714  DEUSE( to );
715  DEUSE( step );
716  return new_error( ERROR_NOT_A_NUMBER, CDR( source ) );
717  }
718 
719 
720 
721  // process the step
722  if (IS_ERROR( step ))
723  {
724  DEUSE( from );
725  DEUSE( to );
726  add_error_source( step, CDR( CDR( source ) ) );
727  return USE( step );
728  }
729 
730  if (IS_UNBOUND( step ))
731  {
732  step_f = (to_f >= from_f) ? 1 : -1;
733  }
734  else
735  if (!atom_to_float( step, &step_f ))
736  {
737  //DEUSE( from );
738  DEUSE( to );
739  DEUSE( step );
740  return new_error( ERROR_NOT_A_NUMBER, CDR( CDR( source ) ) );
741  }
742 
743  DEUSE( *step_value );
744  *step_value = new_float( step_f );
745  //printf("FOR from=%f to=%f step=%f\n",from_f,to_f,step_f);
746 
747  int64_t cnt;
748 
749  if ((to_f >= from_f) && (step_f > 0))
750  cnt = floor( (to_f - from_f) / step_f ) + 1;
751  else
752  if ((to_f <= from_f) && (step_f < 0))
753  cnt = floor( (to_f - from_f) / step_f ) + 1;
754  else
755  cnt = 0;
756 
757  //DEUSE( from );
758  DEUSE( to );
759  DEUSE( step );
760 
761  //printf(" repeat count=%Ld\n",cnt);
762  //printf("---<<< end of RT_FOR_CHK >>>---\n");
763 
764  return new_integer( cnt );
765 }
766 
767 
768 
769 
770 //===================================================
781 //===================================================
782 
783 atom_t RUNTIME rt_print( atom_t pdl, atom_t pwl, atom_t fpp, int data )
784 {
785  //printf("pdl="); dumpln(pdl);
786  //printf("pwl="); dumpln(pwl);
787  //printf("fpp="); dumpln(fpp);
788 
789  // check print-related variabples
792  atom_to_boolean( fpp, &full_print_p );
793 
794  // do the actual print
796  for (EACH_ARGUMENT)
797  {
798  CHECK_PARAM( ARGUMENT );
799  dump( ARGUMENT );
800  outter( TEXT( " " ), 1 );
801  };
802  outter( TEXT( "\n" ), 1 );
803  RETURN( unbound );
804 }
805 
806 
807 
808 //===================================================
819 //===================================================
820 
821 atom_t RUNTIME rt_plus( int count, atom_t data2, atom_t data1 )
822 {
823  float64_t x;
824  float64_t y;
825 
826  GET_FLOAT( data2, y ); // to check whether data2 is number
827 
828  // process unary +
829  if (count == 1) RETURN( USE( data2 ) );
830 
831  // process binary +
832  GET_FLOAT( data1, x );
833  RETURN( new_float( x + y ) );
834 }
835 
836 
837 
838 
839 //===================================================
850 //===================================================
851 
852 atom_t RUNTIME rt_minus( int count, atom_t data2, atom_t data1 )
853 {
854  float64_t x;
855  float64_t y;
856 
857  GET_FLOAT( data2, y );
858 
859  // process unary -
860  if (count == 1) RETURN( new_float(-y ) );
861 
862  // process binary -
863  GET_FLOAT( data1, x );
864  RETURN( new_float( x - y ) );
865 }
866 
867 
868 
869 
870 //===================================================
878 //===================================================
879 
880 atom_t RUNTIME rt_mul( atom_t data2, atom_t data1 )
881 {
882  float64_t x;
883  float64_t y;
884 
885  GET_FLOAT( data1, x );
886  GET_FLOAT( data2, y );
888  RETURN( new_float( x * y ) );
889 }
890 
891 
892 //===================================================
900 //===================================================
901 
902 atom_t RUNTIME rt_div( atom_t data2, atom_t data1 )
903 {
904  float64_t x;
905  float64_t y;
906 
907  GET_FLOAT( data1, x );
908  GET_FLOAT( data2, y );
910  RETURN( new_float( x / y ) );
911 }
912 
913 
914 //===================================================
923 //===================================================
924 
925 atom_t RUNTIME rt_sum( int data )
926 {
927  float64_t acc = 0;
928  float64_t x;
930 
931  for (EACH_ARGUMENT) // Process each given argument
932  {
933  GET_FLOAT( ARGUMENT, x );
934  acc += x;
935  }
936  RETURN( new_float( acc ) );
937 }
938 
939 
940 //===================================================
948 //===================================================
949 
950 atom_t RUNTIME rt_difference( atom_t data2, atom_t data1 )
951 {
952  float64_t x;
953  float64_t y;
954 
955  GET_FLOAT( data1, x );
956  GET_FLOAT( data2, y );
958  RETURN( new_float( x - y ) );
959 }
960 
961 
962 //===================================================
969 //===================================================
970 
972 {
973  float64_t x;
974 
975  GET_FLOAT( data, x );
976 
977  RETURN( new_float(-x ) );
978 }
979 
980 
981 //===================================================
990 //===================================================
991 
992 atom_t RUNTIME rt_product( int data )
993 {
994  float64_t acc = 1;
995  float64_t x;
997 
998  for (EACH_ARGUMENT) // Process each given argument
999  {
1000  GET_FLOAT( ARGUMENT, x );
1001  acc *= x;
1002  }
1003  RETURN( new_float( acc ) );
1004 }
1005 
1006 
1007 //===================================================
1015 //===================================================
1016 
1017 atom_t RUNTIME rt_remainder( atom_t data2, atom_t data1 )
1018 {
1019  int64_t x, y;
1020 
1021  GET_INT( data1, x );
1022  GET_INT( data2, y );
1023 
1024  if( y )
1025  { RETURN( new_integer( x % y ) ); }
1026  else
1027  { RETURN( new_integer( 0 ) ); }
1028 }
1029 
1030 
1031 //===================================================
1038 //===================================================
1039 
1040 atom_t RUNTIME rt_int( atom_t data )
1041 {
1042  float64_t x;
1043 
1044  GET_FLOAT( data, x );
1045 
1046  RETURN( new_integer( (int64_t) x ) );
1048 
1049 
1050 //===================================================
1057 //===================================================
1058 
1059 atom_t RUNTIME rt_round( atom_t data )
1060 {
1061  float64_t x;
1062 
1063  GET_FLOAT( data, x );
1064  x += 0.5 * SIGN( x );
1065  RETURN( new_integer( (int64_t) x ) );
1067 
1068 
1069 //===================================================
1077 //===================================================
1078 
1079 atom_t RUNTIME rt_sqrt( atom_t data )
1080 {
1081  float64_t x;
1082 
1083  GET_FLOAT( data, x );
1084 
1085  x = sqrt( x );
1087 }
1088 
1089 
1090 //===================================================
1098 //===================================================
1099 
1100 atom_t RUNTIME rt_power( atom_t power, atom_t base )
1101 {
1102  float64_t x;
1103  float64_t y;
1104 
1105  GET_FLOAT( base, x );
1106  GET_FLOAT( power, y );
1108  x = pow( x, y );
1109 
1110  RETURN( new_float( x ) );
1111 }
1112 
1113 
1114 //===================================================
1121 //===================================================
1122 
1123 atom_t RUNTIME rt_exp( atom_t power )
1124 {
1125  float64_t x;
1126 
1127  GET_FLOAT( power, x );
1128 
1129  x = exp( x );
1131 }
1132 
1133 
1134 //===================================================
1141 //===================================================
1142 
1143 atom_t RUNTIME rt_log10( atom_t data )
1144 {
1145  float64_t x;
1146 
1147  GET_FLOAT( data, x );
1148 
1149  x = log10( x );
1151 }
1152 
1153 
1154 //===================================================
1161 //===================================================
1162 
1163 atom_t RUNTIME rt_ln( atom_t data )
1164 {
1165  float64_t x;
1166 
1167  GET_FLOAT( data, x );
1168 
1169  x = log( x );
1171 }
1172 
1173 
1174 //===================================================
1181 //===================================================
1182 
1183 atom_t RUNTIME rt_abs( atom_t data )
1184 {
1185  float64_t x;
1186 
1187  GET_FLOAT( data, x );
1188 
1189  x = fabs( x );
1191 }
1192 
1193 
1194 //===================================================
1200 //===================================================
1201 
1202 atom_t RUNTIME rt_pi( void )
1203 {
1204  RETURN( new_float( M_PI ) );
1205 }
1206 
1207 
1208 //===================================================
1215 //===================================================
1216 
1217 atom_t RUNTIME rt_sin( atom_t data )
1218 {
1219  float64_t x;
1220 
1221  GET_FLOAT( data, x );
1222 
1223  // Converts degrees to radians
1224  x = (x / 180) * M_PI;
1225  x = sin( x );
1226 
1227  // Correct precision error from converting degrees to radians
1228  if (fabs( x ) < ZERO_PRECISION)
1229  {
1230  x = 0;
1231  }
1232  else
1233  if (fabs( 0.5 + x ) < ZERO_PRECISION)
1234  {
1235  x = -0.5;
1236  }
1237  else
1238  if (fabs( 0.5 - x ) < ZERO_PRECISION)
1239  {
1240  x = 0.5;
1241  }
1242  else
1243  if (fabs( 1 + x ) < ZERO_PRECISION)
1244  {
1245  x = -1;
1246  }
1247  else
1248  if (fabs( 1 - x ) < ZERO_PRECISION)
1249  {
1250  x = 1;
1251  }
1252 
1253  RETURN( new_float( x ) );
1254 }
1255 
1256 
1257 //===================================================
1264 //===================================================
1265 
1267 {
1268  float64_t x;
1269 
1270  GET_FLOAT( data, x );
1271 
1272  x = sin( x );
1273  if (fabs( x ) < ZERO_PRECISION)
1274  {
1275  x = 0;
1276  }
1277  RETURN( new_float( x ) );
1278 }
1279 
1280 
1281 //===================================================
1288 //===================================================
1289 
1290 atom_t RUNTIME rt_cos( atom_t data )
1291 {
1292  float64_t x;
1293 
1294  GET_FLOAT( data, x );
1295 
1296  // Converts degrees to radians
1297  x = (x / 180) * M_PI;
1298  x = cos( x );
1299 
1300  // Correct precision error from converting degrees to radians
1301  if (fabs( x ) < ZERO_PRECISION)
1302  {
1303  x = 0;
1304  }
1305  else
1306  if (fabs( 0.5 + x ) < ZERO_PRECISION)
1307  {
1308  x = -0.5;
1309  }
1310  else
1311  if (fabs( 0.5 - x ) < ZERO_PRECISION)
1312  {
1313  x = 0.5;
1314  }
1315  else
1316  if (fabs( 1 + x ) < ZERO_PRECISION)
1317  {
1318  x = -1;
1319  }
1320  else
1321  if (fabs( 1 - x ) < ZERO_PRECISION)
1322  {
1323  x = 1;
1324  }
1325 
1326  RETURN( new_float( x ) );
1327 }
1328 
1329 
1330 //===================================================
1337 //===================================================
1338 
1340 {
1341  float64_t x;
1342 
1343  GET_FLOAT( data, x );
1344 
1345  x = cos( x );
1346  if (fabs( x ) < ZERO_PRECISION)
1347  {
1348  x = 0;
1349  }
1350 
1351  RETURN( new_float( x ) );
1352 }
1353 
1354 
1355 //===================================================
1364 //===================================================
1365 
1366 atom_t RUNTIME rt_arctan( int count, atom_t data2, atom_t data1 )
1367 {
1368  float64_t x;
1369  float64_t y;
1370 
1371  GET_FLOAT( data2, y );
1372 
1373  if (count == 1)
1374  {
1375  x = atan( y );
1376  }
1377  else
1378  {
1379  GET_FLOAT( data1, x );
1380  x = atan2( x, y );
1381  }
1382 
1383  //Convert radians to degrees.
1384  x = (x * 180) / M_PI;
1385  RETURN( new_float( x ) );
1386 }
1387 
1388 
1389 //===================================================
1398 //===================================================
1399 
1400 atom_t RUNTIME rt_radarctan( int count, atom_t data2, atom_t data1 )
1401 {
1402  float64_t x;
1403  float64_t y;
1404 
1405  GET_FLOAT( data2, y );
1406 
1407  if (count == 1)
1408  {
1409  x = atan( y );
1410  }
1411  else
1412  {
1413  GET_FLOAT( data1, x );
1414  x = atan2( x, y );
1415  }
1416 
1417  RETURN( new_float( x ) );
1418 }
1419 
1420 
1421 //===================================================
1435 //===================================================
1436 
1437 atom_t RUNTIME rt_make( int static_link, atom_t parent, atom_t value, atom_t name )
1438 {
1439  //printf("rt_make, var="); dumpln(name);
1440  //printf("rt_make, val="); dumpln(value);
1441 
1442  if (IS_ERROR( value )) RETURN( USE(value) );
1443  if (IS_ERROR( name )) RETURN( USE(name) );
1445  atom_t word = atom_to_word( name );
1446  if (IS_ERROR( word )) RETURN( word );
1447 
1448  atom_t var = find_runtime_var( word, static_link );
1449 
1450  // not found - create a global one
1451  if (!var)
1452  {
1453  var = new_var( word, globals, 1 );
1454  SET_FLAGS( var, FLAG_VARIABLE );
1455  VARTYPE( var ) = VAR_TYPE_RUNTIME;
1456  VALUE( var ) = USE( unbound );
1457  }
1458 
1459  // var name as a word is not needed any more
1460  DEUSE( word );
1461 
1462  // not a variable (i.e. it is a function or a procedure)
1463  if (!IS_VARIABLE( var ))
1464  RETURN( new_error( ERROR_NOT_A_VAR, name ) );
1465 
1466  //printf("rt_make, var="); dumpln(var);
1467  //printf("rt_make, val="); dumpln(value);
1468  rt_set_var_value( static_link, parent, var, value );
1469  //printf("value is set, see var(%x)=",(int)var); dumpln(var);
1470  //printf(" its parent is="); dumpln(PARENT(var));
1471  RETURN( unbound );
1472 }
1473 
1474 
1475 
1476 
1477 //===================================================
1487 //===================================================
1488 
1489 atom_t RUNTIME rt_name( int static_link, atom_t parent, atom_t name, atom_t value )
1490 {
1491  // no need to use RETURN, because rt_make() has a RETURN
1492  return ( rt_make( static_link, parent, value, name ));
1493 }
1494 
1495 
1497 //===================================================
1507 //===================================================
1508 
1509 atom_t RUNTIME rt_local( int static_link, atom_t parent, int data )
1510 {
1511  atom_t* localsp;
1512  localsp = (atom_t*) (static_link + BASE_OFFSET_LOCALS);
1513  //printf("rt_local\n");
1514  atom_t ARGUMENT;
1515  for (EACH_ARGUMENT)
1516  {
1517  //printf("creating local var: "); dumpln(ARGUMENT);
1518  if (IS_ERROR( ARGUMENT )) RETURN( USE( ARGUMENT ) );
1519  if (IS_UNBOUND( ARGUMENT ))
1520  {
1522  }
1523 
1524  // check whether this variable exists locally
1525  if (find_local_var( ARGUMENT, parent ) ||
1526  find_local_var( ARGUMENT, *localsp ))
1527  {
1528  return new_error( ERROR_DUPLICATE_INPUT, ARGUMENT );
1529  }
1530 
1531  atom_t var = new_var( ARGUMENT, parent, 0 );
1532  SET_FLAGS( var, FLAG_VARIABLE );
1533  VALUE( var ) = USE( unbound );
1534  VARTYPE( var ) = VAR_TYPE_RUNTIME;
1535  *localsp = new_list( var, *localsp ); // attach to other runtimers
1536  };
1537  //printf("new locals="); dumpln(*localsp);
1538  RETURN( unbound );
1539 }
1540 
1541 
1542 //===================================================
1553 //===================================================
1554 
1555 int num_compare( float64_t x, float64_t y )
1556 {
1557  if (x < y) return -1;
1558  if (y < x) return 1;
1559  return 0; // x == y
1560 }
1561 
1563 //===================================================
1577 //===================================================
1578 
1579 int word_compare( int cip, chars_t w1, int w1_len, chars_t w2, int w2_len )
1580 {
1581  if (!cip)
1582  {
1583  while (w1_len && w2_len)
1584  {
1585  if (DEBAR( w1[0] ) != DEBAR( w2[0] ))
1586  return DEBAR( w1[0] ) - DEBAR( w2[0] );
1587  ++w1;
1588  ++w2;
1589  --w1_len;
1590  --w2_len;
1591  }
1592  }
1593  else
1594  {
1595  while (w1_len && w2_len)
1596  {
1597  if (TOLOWER( DEBAR( w1[0] ) ) != TOLOWER( DEBAR( w2[0] ) ))
1598  return TOLOWER( DEBAR( w1[0] ) ) - TOLOWER( DEBAR( w2[0] ) );
1599  ++w1;
1600  ++w2;
1601  --w1_len;
1602  --w2_len;
1603  }
1604  }
1605  return w1_len - w2_len;
1606 }
1607 
1608 
1609 // Function prototype
1610 int atom_equal( atom_t cip, atom_t data2, atom_t data1 );
1611 
1612 //===================================================
1623 //===================================================
1624 
1625 int list_equal( atom_t cip, atom_t data1, atom_t data2 )
1626 {
1627  int comp;
1628  //atom_t comp_res;
1629 
1630  while (IS_NOT_EMPTY( data1 ) && IS_NOT_EMPTY( data2 ))
1631  {
1632  comp = atom_equal( cip, CAR( data2 ), CAR( data1 ) );
1633  if (comp <= 0)
1634  {
1635  return comp;
1636  }
1637 
1638  data1 = CDR( data1 );
1639  data2 = CDR( data2 );
1640  }
1641  return (IS_EMPTY( data1 ) && IS_EMPTY( data2 ));
1642 }
1643 
1644 
1645 //===================================================
1657 //===================================================
1658 
1659 int atom_equal( atom_t cip, atom_t data2, atom_t data1 )
1660 {
1661  float64_t x;
1662  int case_ignore = 0;
1663 
1664  // printf("*****00000000****"); dump_statistics();
1665 
1666  // test if atoms are different types and one is list
1667  // in that case they cannot be equal
1668  if ((IS_LIST( data1 ) || IS_LIST( data2 )) &&
1669  (ID( data1 ) != ID( data2 )))
1670  {
1671  return 0;
1672  }
1673 
1674  // Now we know that both are lists or both are not lists
1675  if (IS_LIST( data1 ))
1676  {
1677  return list_equal( cip, data1, data2 );
1678  }
1679 
1680  if (!atom_to_boolean( cip, &case_ignore ))
1681  {
1682  case_ignore = 1;
1683  }
1684 
1685  // If both atoms are words - best way to compare them is directly
1686  if (IS_ANY_WORD( data1 ) && IS_ANY_WORD( data2 ))
1687  {
1688  int xx = word_compare( case_ignore, STRING( data1 ), LENGTH( data1 ), STRING( data2 ), LENGTH( data2 ) ) == 0;
1689  return xx;
1690  }
1691 
1692  // Here we are in case that both are numbers or unsupported types
1693  if (atom_to_float( data1, &x ))
1694  {
1695  // First is a number
1696  float64_t y;
1697  if (!atom_to_float( data2, &y ))
1698  {
1699  return 0;
1700  }
1701  return num_compare( x, y ) == 0; // Both are numbers
1702  }
1703 
1704  return -1; //Different or unsupproted atom types -> error
1705 }
1706 
1707 
1708 
1709 //===================================================
1718 //===================================================
1719 
1720 atom_t RUNTIME rt_equal( atom_t cip, atom_t data2, atom_t data1 )
1721 {
1722  int comp;
1723  // parameter checking
1724  if (IS_ERROR( data1 )) RETURN( USE(data1) );
1725  if (IS_ERROR( data2 )) RETURN( USE(data2) );
1726 
1727  comp = atom_equal( cip, data2, data1 );
1728  if (comp < 0)
1729  {
1730  RETURN( new_error( ERROR_MISSING_VALUE, data2 ) );
1731  }
1732 
1733  RETURN( USE( false_true[comp > 0] ) );
1734 }
1735 
1736 
1737 //===================================================
1746 //===================================================
1747 
1748 atom_t RUNTIME rt_nequal( atom_t cip, atom_t data2, atom_t data1 )
1749 {
1750  int comp;
1751  // parameter checking
1752  if (IS_ERROR( data1 )) RETURN( USE(data1) );
1753  if (IS_ERROR( data2 )) RETURN( USE(data2) );
1754 
1755  comp = atom_equal( cip, data2, data1 );
1756  if (comp < 0)
1757  {
1758  RETURN( new_error( ERROR_MISSING_VALUE, data2 ) );
1759  }
1760 
1761  RETURN( USE( false_true[comp == 0] ) );
1762 }
1763 
1764 
1765 //===================================================
1774 //===================================================
1775 
1776 atom_t RUNTIME rt_less( atom_t data2, atom_t data1 )
1777 {
1778  float64_t x;
1779  float64_t y;
1780 
1781  GET_FLOAT( data1, x );
1782  GET_FLOAT( data2, y );
1784  RETURN( USE( false_true[x < y] ) );
1785 }
1786 
1787 
1788 //===================================================
1797 //===================================================
1798 
1799 atom_t RUNTIME rt_more( atom_t data2, atom_t data1 )
1800 {
1801  float64_t x;
1802  float64_t y;
1803 
1804  GET_FLOAT( data1, x );
1805  GET_FLOAT( data2, y );
1807  RETURN( USE( false_true[x > y] ) );
1808 }
1809 
1810 
1811 //===================================================
1820 //===================================================
1821 
1822 atom_t RUNTIME rt_lesseq( atom_t data2, atom_t data1 )
1823 {
1824  float64_t x;
1825  float64_t y;
1826 
1827  GET_FLOAT( data1, x );
1828  GET_FLOAT( data2, y );
1830  RETURN( USE( false_true[x <= y] ) );
1831 }
1832 
1833 
1834 //===================================================
1843 //===================================================
1844 
1845 atom_t RUNTIME rt_moreeq( atom_t data2, atom_t data1 )
1846 {
1847  float64_t x;
1848  float64_t y;
1849 
1850  GET_FLOAT( data1, x );
1851  GET_FLOAT( data2, y );
1852  RETURN( USE( false_true[x >= y] ) );
1853 }
1854 
1855 
1856 //===================================================
1868 //===================================================
1869 
1870 atom_t RUNTIME rt_before( atom_t cip, atom_t data2, atom_t data1 )
1871 {
1873  int len_x = MAX_NUMBER_WORD_LENGTH;
1874  int len_y = MAX_NUMBER_WORD_LENGTH;
1875  chars_t word_x;
1876  chars_t word_y;
1877  int case_ignore = 0;
1878 
1879 
1880  // parameter checking
1881  if (IS_ERROR( data1 )) RETURN( USE(data1) );
1882  if (IS_ERROR( data2 )) RETURN( USE(data2) );
1883 
1884  if (IS_ANY_WORD( data1 ))
1885  {
1886  word_x = STRING( data1 );
1887  len_x = LENGTH( data1 );
1888  }
1889  else if (atom_to_string( data1, x, &len_x ))
1890  {
1891  word_x = x;
1892  }
1893  else
1894  {
1895  RETURN( USE( false_true[0] ) );
1896  }
1897 
1898  if (IS_ANY_WORD( data2 ))
1899  {
1900  word_y = STRING( data2 );
1901  len_y = LENGTH( data2 );
1902  }
1903  else if (atom_to_string( data2, y, &len_y ))
1904  {
1905  word_y = y;
1906  }
1907  else
1908  {
1909  RETURN( USE( false_true[0] ) );
1910  }
1911 
1912  if (!atom_to_boolean( cip, &case_ignore ))
1913  {
1914  case_ignore = 1;
1915  }
1916 
1917  RETURN( USE( false_true[word_compare( case_ignore, word_x, len_x, word_y, len_y ) < 0] ) );
1918 }
1919 
1920 
1921 
1922 //===================================================
1931 //===================================================
1932 
1934 {
1935  RETURN( unbound );
1936 }
1937 
1938 
1939 
1940 //===================================================
1949 //===================================================
1950 
1952 {
1953  RETURN( unbound );
1954 }
1955 
1956 
1957 
1958 //===================================================
1966 //===================================================
1967 
1969 {
1970  RETURN( unbound );
1971 }
1972 
1973 
1974 
1975 //===================================================
1983 //===================================================
1984 #define rt_dump __attribute__((used,noinline,regparm(0),stdcall)) rt_dump
1985 
1986 atom_t rt_dump( atom_t source )
1987 #undef rt_dump
1988 {
1989 #ifdef ADVANCED
1990  if (OPTION_RUNTIME)
1991  {
1992  outter( TEXT( "DONE " ), -1 );
1993  dumpln( source );
1994  }
1995 #endif
1996 
1997  return unbound;
1998 }
1999 
2000 
2001 
2002 //===================================================
2012 //===================================================
2013 #define rt_predump __attribute__((used,noinline,regparm(0),stdcall)) rt_predump
2014 
2015 atom_t rt_predump( atom_t source )
2016 #undef rt_predump
2017 {
2018 #ifdef ADVANCED
2019  if (OPTION_RUNTIME)
2020  {
2021  outter( TEXT( "TODO " ), -1 );
2022  dumpln( source );
2023  }
2024 #endif
2025 
2026  return unbound;
2027 }
2028 
2029 
2030 
2031 //===================================================
2041 //===================================================
2042 
2043 atom_t RUNTIME rt_and( int data )
2044 {
2045  int param;
2046  atom_t ARGUMENT;
2047 
2048  for (EACH_ARGUMENT)
2049  {
2050  GET_BOOLEAN( ARGUMENT, param );
2051  if (!param)
2052  {
2053  RETURN( USE( false_true[0] ) );
2054  }
2055  }
2056  RETURN( USE( false_true[1] ) );
2057 }
2058 
2059 
2060 //===================================================
2070 //===================================================
2071 
2072 atom_t RUNTIME rt_or( int data )
2073 {
2074  int param;
2075  atom_t ARGUMENT;
2076 
2077  for (EACH_ARGUMENT)
2078  {
2079  GET_BOOLEAN( ARGUMENT, param );
2080  if (param)
2081  {
2082  RETURN( USE( false_true[1] ) );
2083  }
2084  }
2085  RETURN( USE( false_true[0] ) );
2086 }
2087 
2088 
2089 //===================================================
2097 //===================================================
2098 
2099 atom_t RUNTIME rt_not( atom_t data )
2100 {
2101  int result;
2102  GET_BOOLEAN( data, result );
2103  RETURN( USE( false_true[1 - result] ) );
2104 }
2105 
2107 //===================================================
2116 //===================================================
2117 
2119 {
2120  if (IS_ERROR( data ))
2121  {
2122  RETURN( USE( data ) );
2123  }
2124  else
2125  {
2126  RETURN( USE( unbound ) );
2127  }
2128 }
2129 
2130 
2131 //===================================================
2139 //===================================================
2140 
2141 atom_t RUNTIME rt_first( atom_t data )
2142 {
2144  int buff_len = MAX_NUMBER_WORD_LENGTH;
2145 
2146  // parameter checking
2147  if (IS_ERROR( data )) RETURN( USE(data) );
2149  if (IS_LIST( data ))
2150  {
2151  if (IS_EMPTY( data ))
2152  {
2153  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2154  }
2155  RETURN( USE( CAR( data ) ) );
2156  }
2157  if (IS_ANY_WORD( data ))
2158  {
2159  if (LENGTH( data ) == 0)
2160  {
2161  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2162  }
2163 
2164  RETURN( new_subword( data, STRING( data ), 1 ) );
2165  }
2166  if (atom_to_string( data, buff, &buff_len ))
2167  {
2168  if (buff_len == 0)
2169  {
2170  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2171  }
2172 
2173  RETURN( new_word( buff, 1 ) );
2174  }
2175  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2176 }
2177 
2178 
2179 //===================================================
2187 //===================================================
2188 
2190 {
2192  int buff_len = MAX_NUMBER_WORD_LENGTH;
2193 
2194  // parameter checking
2195  if (IS_ERROR( data )) RETURN( USE(data) );
2197  if (IS_LIST( data ))
2198  {
2199  if (IS_EMPTY( data ))
2200  {
2201  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2202  }
2203  RETURN( USE( CDR( data ) ) );
2204  }
2205  if (IS_ANY_WORD( data ))
2206  {
2207  if (LENGTH( data ) == 0)
2208  {
2209  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2210  }
2211  RETURN( new_subword( data, STRING( data ) + 1, LENGTH( data ) - 1 ) );
2212  }
2213  if (atom_to_string( data, buff, &buff_len ))
2214  {
2215  if (buff_len == 0)
2216  {
2217  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2218  }
2219 
2220  RETURN( new_word( buff + 1, buff_len - 1 ) );
2221  }
2222  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2223 }
2224 
2225 
2226 //===================================================
2234 //===================================================
2235 
2237 {
2238  atom_t result, iter;
2239  result = iter = empty_list;
2240 
2241  // parameter checking
2242  if (IS_ERROR( data )) RETURN( USE(data) );
2243  if (!IS_LIST( data )) RETURN( new_error( ERROR_NOT_A_LIST, data ) );
2244 
2245  while (!IS_EMPTY( data ))
2246  {
2247  append( rt_first( CAR( data ) ), &result, &iter );
2248  data = CDR( data );
2249  }
2250  RETURN( result );
2251 }
2252 
2253 //===================================================
2261 //===================================================
2262 
2264 {
2265  atom_t result, iter;
2266  result = iter = empty_list;
2267 
2268  // parameter checking
2269  if (IS_ERROR( data )) RETURN( USE(data) );
2270  if (!IS_LIST( data )) RETURN( new_error( ERROR_NOT_A_LIST, data ) );
2271 
2272  while (!IS_EMPTY( data ))
2273  {
2274  append( rt_butfirst( CAR( data ) ), &result, &iter );
2275  data = CDR( data );
2276  }
2277  RETURN( result );
2278 }
2279 
2280 
2281 //===================================================
2289 //===================================================
2290 
2291 atom_t RUNTIME rt_last( atom_t data )
2292 {
2294  int buff_len = MAX_NUMBER_WORD_LENGTH;
2295 
2296  // parameter checking
2297  if (IS_ERROR( data )) RETURN( USE(data) );
2299  if (IS_LIST( data ))
2300  {
2301  if (IS_EMPTY( data ))
2302  {
2303  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2304  }
2305  RETURN( USE( get_at_list( data, -1 ) ) );
2306  }
2307  if (IS_ANY_WORD( data ))
2308  {
2309  if (LENGTH( data ) == 0)
2310  {
2311  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2312  }
2313 
2314  RETURN( new_subword( data, STRING( data ) + LENGTH( data ) - 1, 1 ) );
2315  }
2316  if (atom_to_string( data, buff, &buff_len ))
2317  {
2318  if (buff_len == 0)
2319  {
2320  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2321  }
2322 
2323  RETURN( new_word( buff + buff_len - 1, 1 ) );
2324  }
2325  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2326 }
2327 
2328 
2329 //===================================================
2337 //===================================================
2338 
2340 {
2342  int buff_len = MAX_NUMBER_WORD_LENGTH;
2343 
2344  // parameter checking
2345  if (IS_ERROR( data )) RETURN( USE(data) );
2347  if (IS_LIST( data ))
2348  {
2349  if (IS_EMPTY( data ))
2350  {
2351  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2352  }
2353  RETURN( list_copy_but_last( data ) );
2354  }
2355  if (IS_ANY_WORD( data ))
2356  {
2357  if (LENGTH( data ) == 0)
2358  {
2359  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2360  }
2361  RETURN( new_subword( data, STRING( data ), LENGTH( data ) - 1 ) );
2362  }
2363  if (atom_to_string( data, buff, &buff_len ))
2364  {
2365  if (buff_len == 0)
2366  {
2367  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2368  }
2369 
2370  RETURN( new_word( buff, buff_len - 1 ) );
2371  }
2372  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2373 }
2374 
2375 
2376 //===================================================
2386 //===================================================
2387 
2388 atom_t RUNTIME rt_item( atom_t data, atom_t index )
2389 {
2390  int64_t ind;
2392  int buff_len = MAX_NUMBER_WORD_LENGTH;
2393 
2394  // parameters check
2395  if (IS_ERROR( data )) RETURN( USE(data) );
2396  GET_INT( index, ind );
2397 
2398  if (ind <= 0)
2399  {
2400  RETURN( new_error( ERROR_NOT_A_NUMBER, index ) );
2401  }
2402 
2403  if (IS_LIST( data ))
2404  {
2405  if (IS_EMPTY( data ))
2406  {
2407  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2408  }
2409  RETURN( USE( get_at_list( data, ind - 1 ) ) ); // -1 cause indexing starts from 1
2410  }
2411  if (IS_ANY_WORD( data ))
2412  {
2413  if (LENGTH( data ) < ind)
2414  {
2415  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2416  }
2417 
2418  RETURN( new_subword( data, STRING( data ) + ind - 1, 1 ) );
2419  }
2420  if (atom_to_string( data, buff, &buff_len ))
2421  {
2422  if (buff_len < ind)
2423  {
2424  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2425  }
2426 
2427  RETURN( new_word( buff + ind - 1, 1 ) );
2428  }
2429  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
2430 }
2431 
2432 
2433 
2434 
2435 //===================================================
2444 //===================================================
2445 
2446 atom_t RUNTIME rt_if( int count )
2447 {
2448  RETURN( unbound );
2449 }
2450 
2451 
2452 
2454 //===================================================
2464 //===================================================
2465 
2466 atom_t RUNTIME rt_repeat( atom_t repcount, atom_t commands )
2467 {
2468  RETURN( unbound );
2469 }
2470 
2471 
2472 
2473 //===================================================
2483 //===================================================
2484 
2485 atom_t RUNTIME rt_while( atom_t condition, atom_t commands )
2486 {
2487  RETURN( unbound );
2488 }
2489 
2490 
2491 
2492 //===================================================
2502 //===================================================
2503 
2504 atom_t RUNTIME rt_dowhile( atom_t commands, atom_t condition )
2505 {
2506  RETURN( unbound );
2507 }
2508 
2509 
2510 
2511 //===================================================
2521 //===================================================
2522 
2523 atom_t RUNTIME rt_until( atom_t condition, atom_t commands )
2524 {
2525  RETURN( unbound );
2526 }
2527 
2528 
2529 
2530 //===================================================
2540 //===================================================
2541 
2542 atom_t RUNTIME rt_dountil( atom_t commands, atom_t condition )
2543 {
2544  RETURN( unbound );
2545 }
2546 
2547 
2548 
2549 //===================================================
2563 //===================================================
2564 #define rt_whlchk __attribute__((used,noinline,regparm(0),stdcall)) rt_whlchk
2565 
2566 atom_t rt_whlchk( atom_t source, atom_t data )
2567 #undef rt_whlchk
2568 {
2569  if (IS_ERROR( data ))
2570  {
2571  add_error_source( data, source );
2572  return USE( data );
2573  }
2574 
2575  if (IS_UNBOUND( data ))
2576  {
2577  DEUSE( data );
2578  return new_error( ERROR_MISSING_VALUE, source );
2579  }
2580 
2581  int b;
2582  if (!atom_to_boolean( data, &b ))
2583  {
2584  DEUSE( data );
2585  return new_error( ERROR_BOOLEAN_EXPECTED, source );
2586  }
2587 
2588  DEUSE( data );
2589 
2590  return new_integer( b );
2591 }
2592 
2593 
2594 
2595 
2596 //===================================================
2607 //===================================================
2608 #define void void __attribute__ ((used,noinline,regparm(0),stdcall))
2609 
2610 void rt_repeat_enter( int frame, int count )
2611 #undef void
2612 {
2613  atom_t* chain_ptr;
2614  atom_t node;
2615 
2616  node = new_integer( 0 );
2617  REPCOUNT( node ) = 1;
2618  REPLIMIT( node ) = count;
2619 
2620  chain_ptr = (atom_t*) (frame + BASE_OFFSET_REPEATCHAIN);
2621  if (IS_UNBOUND( *chain_ptr ))
2622  {
2623  // we create the first repeat-node
2624  DEUSE( *chain_ptr );
2625  *chain_ptr = new_list( node, empty_list );
2626  }
2627  else
2628  {
2629  // we add a new repeat-node
2630  *chain_ptr = new_list( node, *chain_ptr );
2631  }
2632 }
2633 
2634 
2635 
2636 //===================================================
2644 //===================================================
2645 #define void atom_t __attribute__ ((used,noinline,regparm(0),stdcall))
2646 
2647 void rt_repeat_exit( int frame )
2648 #undef void
2649 {
2650  atom_t* chain_ptr;
2651 
2652  chain_ptr = (atom_t*) (frame + BASE_OFFSET_REPEATCHAIN);
2653 
2654  if (!IS_UNBOUND( *chain_ptr ))
2655  {
2656 #ifdef SAFEMODE
2657  assert( IS_LIST( *chain_ptr ) );
2658 #endif
2659 
2660  *chain_ptr = behead( *chain_ptr );
2661 
2662  if (IS_EMPTY( *chain_ptr ))
2663  *chain_ptr = USE( unbound );
2664  }
2665 
2666  //printf("exitus repeatus\n");
2667  RETURN( unbound );
2668 }
2669 
2670 
2671 
2672 //===================================================
2682 //===================================================
2683 
2684 atom_t RUNTIME rt_repcount( int frame )
2685 {
2686  atom_t* chain_ptr;
2687 
2688  while (frame)
2689  {
2690  chain_ptr = (atom_t*) (frame + BASE_OFFSET_REPEATCHAIN);
2692  if (IS_LIST( *chain_ptr ))
2693  RETURN( new_integer( REPCOUNT( CAR( *chain_ptr ) ) ) );
2694 
2695  frame = *((int*) (frame));
2696  }
2697 
2698  RETURN( new_integer(-1 ) );
2699 }
2700 
2701 
2702 
2703 //===================================================
2712 //===================================================
2713 
2714 atom_t RUNTIME rt_forever( atom_t commands )
2715 {
2716  RETURN( unbound );
2717 }
2718 
2719 
2720 
2721 //===================================================
2734 //===================================================
2735 #define void void __attribute__ ((used,noinline,regparm(0),stdcall))
2736 
2737 void rt_forever_enter( int frame )
2738 #undef void
2739 {
2740  atom_t* chain_ptr;
2741  atom_t node;
2743  node = new_integer( 0 );
2744  REPCOUNT( node ) = 1;
2745  REPLIMIT( node ) = 1;
2746 
2747  chain_ptr = ((atom_t*) (frame + BASE_OFFSET_REPEATCHAIN));
2748  if (IS_UNBOUND( *chain_ptr ))
2749  {
2750  // we create the first repeat-node
2751  DEUSE( *chain_ptr );
2752  *chain_ptr = new_list( node, empty_list );
2753  }
2754  else
2755  {
2756  // we add a new repeat-node
2757  *chain_ptr = new_list( node, *chain_ptr );
2758  }
2759 }
2760 
2761 
2762 
2763 //===================================================
2771 //===================================================
2772 
2773 atom_t RUNTIME rt_parse( atom_t data )
2774 {
2775  if (IS_ERROR( data ))
2776  RETURN( USE(data) );
2777 
2778  RETURN( tokenize( data, TOKENIZE_DATA ) );
2779 }
2781 
2782 
2783 
2784 //===================================================
2792 //===================================================
2793 
2795 {
2796  if (IS_ERROR( data ))
2797  RETURN( USE(data) );
2798 
2799  //printf("dddaaataa="); dumpln(data);
2800  atom_t tokens1 = tokenize( data, TOKENIZE_DATA );
2801  //printf("reresultt="); dumpln(tokens1);
2802  if (IS_ERROR( tokens1 )) RETURN( tokens1 );
2803 
2804  atom_t tokens2 = tokenize( tokens1, TOKENIZE_COMMANDS );
2805  DEUSE( tokens1 );
2806  if (IS_ERROR( tokens2 )) RETURN( tokens2 );
2807 
2808  RETURN( tokens2 );
2809 }
2810 
2811 
2812 //===================================================
2820 //===================================================
2821 
2822 atom_t RUNTIME rt_wordp( atom_t data )
2823 {
2824  if (IS_ANY_WORD( data ) || IS_INTEGER( data ) || IS_FLOAT( data ))
2825  {
2826  RETURN( USE( false_true[1] ) );
2827  }
2828  else
2829  {
2831  int buff_len = MAX_NUMBER_WORD_LENGTH;
2832 
2833  if (atom_to_string( data, buff, &buff_len ))
2834  {
2835  RETURN( USE( false_true[1] ) );
2836  }
2837  }
2838  RETURN( USE( false_true[0] ) );
2839 }
2840 
2841 
2842 //===================================================
2850 //===================================================
2851 
2852 atom_t RUNTIME rt_listp( atom_t data )
2853 {
2854  RETURN( USE( false_true[IS_LIST( data )] ) );
2855 }
2856 
2857 
2858 //===================================================
2866 //===================================================
2867 
2869 {
2870  float64_t x;
2871 
2872  // number atom atom
2873  if (IS_INTEGER( data ) || IS_FLOAT( data ))
2874  {
2876  }
2877 
2878  // Can be converted to num
2879  if (atom_to_float( data, &x ))
2880  {
2881  RETURN( USE( false_true[1] ) );
2882  }
2883 
2884  // Not a number
2885  RETURN( USE( false_true[0] ) );
2886 }
2887 
2888 
2889 //===================================================
2898 //===================================================
2899 
2900 atom_t RUNTIME rt_empty( atom_t data )
2901 {
2902  if (IS_LIST( data ))
2903  {
2904  RETURN( USE( false_true[IS_EMPTY( data )] ) );
2905  }
2906 
2907  // Empty word
2908  if (IS_ANY_WORD( data ) && LENGTH( data ) == 0)
2909  {
2910  RETURN( USE( false_true[1] ) );
2911  }
2912 
2913  // Not a list or empty word
2914  RETURN( USE( false_true[0] ) );
2915 }
2916 
2917 
2918 //===================================================
2931 //===================================================
2932 
2933 atom_t RUNTIME rt_memberp( atom_t cip, atom_t data, atom_t elem )
2934 {
2935 
2936  if (IS_LIST( data ))
2937  { // Test all elements of the list for equality with elem
2938  while (!IS_EMPTY( data ))
2939  {
2940  if (atom_equal( cip, CAR( data ), elem ))
2941  RETURN( USE( false_true[1] ) );
2942  data = CDR( data );
2943  }
2944  RETURN( USE( false_true[0] ) );
2945  }
2946  else
2947  {
2949  chars_t comp_buffer;
2950  int buff_len = MAX_NUMBER_WORD_LENGTH; // We start with 3 symbols. Actually need 1, but test if there is more
2951  char_t elem_ch;
2952 
2953  // If data is not a list, elem must be one character word
2954  if (IS_ANY_WORD( elem ) && LENGTH( elem ) != 1)
2955  {
2956  RETURN( USE( false_true[0] ) );
2957  }
2958  if (!IS_ANY_WORD( elem ) && (!atom_to_string( elem, buff, &buff_len ) || buff_len != 1))
2959  {
2960  RETURN( USE( false_true[0] ) );
2961  }
2962 
2963  if (buff_len == 1) // elem is one char word -> Store it
2964  {
2965  elem_ch = DEBAR( buff[0] );
2966  }
2967  else
2968  {
2969  elem_ch = DEBAR( STRING( elem )[0] );
2970  }
2971 
2972  if (IS_ANY_WORD( data ))
2973  {
2974  comp_buffer = STRING( data );
2975  buff_len = LENGTH( data );
2976  }
2977  else
2978  {
2979  buff_len = MAX_NUMBER_WORD_LENGTH;
2980  if (!atom_to_string( data, buff, &buff_len ) || buff_len == 0)
2981  {
2982  RETURN( USE( false_true[0] ) ); // data is not a word or empty
2983  }
2984  comp_buffer = buff;
2985  }
2986  while (buff_len--)
2987  {
2988  if (DEBAR( comp_buffer[buff_len] ) == elem_ch)
2989  {
2990  RETURN( USE( false_true[1] ) );
2991  }
2992  }
2993  RETURN( USE( false_true[0] ) );
2994  }
2995 }
2996 
2997 
2998 //===================================================
3009 //===================================================
3010 
3011 atom_t RUNTIME rt_word( int data )
3012 {
3013  atom_t ARGUMENT;
3014  atom_t res;
3015 
3017  int buff_len = MAX_NUMBER_WORD_LENGTH;
3018  int total_length = 0, real_length = 0;
3019 
3020  // First calculate estimate length of result
3021  for (EACH_ARGUMENT)
3022  {
3023  //printf("=======arg="); dumpln(ARGUMENT);
3024  if (IS_ERROR( ARGUMENT ))
3025  {
3026  RETURN( USE(ARGUMENT) );
3027  }
3028 
3029  if (IS_ANY_WORD( ARGUMENT ))
3030  {
3031  total_length += LENGTH( ARGUMENT );
3032  }
3033  else
3034  {
3035  // Assume data can be translated to string.
3036  total_length += MAX_NUMBER_WORD_LENGTH;
3037  }
3038  }
3039 
3040  // Allocate memory
3041  res = create_word( total_length );
3042 
3043  // And copy elements one by one
3044  for (EACH_ARGUMENT)
3045  {
3046  if (IS_ANY_WORD( ARGUMENT ))
3047  {
3048  STRNCPY( STRING( res ) + real_length, STRING( ARGUMENT ), LENGTH( ARGUMENT ) );
3049  real_length += LENGTH( ARGUMENT );
3050  }
3051  else
3052  {
3053  buff_len = MAX_NUMBER_WORD_LENGTH;
3054  if (!atom_to_string( ARGUMENT, buff, &buff_len ))
3055  {
3056  DEUSE( res );
3057  RETURN( new_error( ERROR_NOT_A_WORD, ARGUMENT ) );
3058  }
3059 
3060  STRNCPY( STRING( res ) + real_length, buff, buff_len );
3061  real_length += buff_len;
3062  }
3063  }
3064 
3065  // If allocated more memory than needed reallocate to free unused
3066  if (real_length != total_length)
3067  {
3068  STRING( res ) = REALLOC( STRING( res ), (real_length + 1) * sizeof (char_t) );
3069  IDLENGTH( res ) = WORD_ID | (real_length << 8);
3070  }
3071 
3072  STRING( res )[real_length] = NULL_CHAR;
3073  RETURN( res );
3074 }
3075 
3076 
3077 //===================================================
3088 //===================================================
3089 
3090 atom_t RUNTIME rt_list( int data )
3091 {
3092  atom_t ARGUMENT;
3093  atom_t res, iter;
3094 
3095  iter = res = empty_list;
3096 
3098  {
3099  if (IS_ERROR( ARGUMENT ))
3100  {
3101  RETURN( USE(ARGUMENT) );
3102  }
3103  }
3104 
3105  for (EACH_ARGUMENT)
3106  {
3107  append( USE( ARGUMENT ), &res, &iter );
3108  }
3109 
3110  RETURN( res );
3111 }
3112 
3113 
3114 //===================================================
3126 //===================================================
3127 
3128 atom_t RUNTIME rt_sent( int data )
3129 {
3130  atom_t ARGUMENT;
3131  atom_t res, iter;
3132 
3133  iter = res = empty_list;
3134  for (EACH_ARGUMENT)
3135  {
3136  if (IS_ERROR( ARGUMENT ))
3137  {
3138  RETURN( USE(ARGUMENT) );
3139  }
3140  }
3141 
3142  for (EACH_ARGUMENT)
3143  {
3144  if (IS_LIST( ARGUMENT ))
3145  {
3146  atom_t curr = ARGUMENT;
3147 
3148  while (IS_NOT_EMPTY( curr ))
3149  {
3150  test_elem_and_destroy_if_error( curr, res );
3151  append( USE( CAR( curr ) ), &res, &iter );
3152  curr = CDR( curr );
3153  }
3154  }
3155  else
3156  {
3157  append( USE( ARGUMENT ), &res, &iter );
3158  }
3159  }
3160 
3161  RETURN( res );
3162 }
3163 
3164 
3165 //===================================================
3175 //===================================================
3176 
3177 atom_t RUNTIME rt_fput( atom_t data2, atom_t data1 )
3178 {
3179  if (IS_ERROR( data1 )) RETURN( USE(data1) );
3180  if (IS_ERROR( data2 )) RETURN( USE(data2) );
3181 
3182  if (IS_LIST( data2 ))
3183  {
3184  RETURN( new_list( USE( data1 ), USE( data2 ) ) );
3185  }
3186  else
3187  {
3189  int buff_len2 = MAX_NUMBER_WORD_LENGTH;
3190 
3192  int buff_len1 = MAX_NUMBER_WORD_LENGTH;
3193 
3194  atom_t res;
3195 
3196  /* check parametr correctness */
3197  if (!IS_ANY_WORD( data2 ) && !atom_to_string( data2, buff2, &buff_len2 ))
3198  {
3199  RETURN( new_error( ERROR_NOT_A_WORD, data2 ) );
3200  }
3201 
3202  if ((IS_ANY_WORD( data1 ) && LENGTH( data1 ) != 1) ||
3203  (!atom_to_string( data1, buff1, &buff_len1 ) || buff_len1 != 1))
3204  {
3206  }
3207 
3208  if (IS_ANY_WORD( data2 ))
3209  {
3210  res = create_word( 1 + LENGTH( data2 ) );
3211  STRING( res )[0] = IS_ANY_WORD( data1 ) ? STRING( data1 )[0] : buff1[0];
3212  STRNCPY( STRING( res ) + 1, STRING( data2 ), LENGTH( data2 ) );
3213  }
3214  else
3215  {
3216  res = create_word( 1 + buff_len2 );
3217  STRING( res )[0] = IS_ANY_WORD( data1 ) ? STRING( data1 )[0] : buff1[0];
3218  STRNCPY( STRING( res ) + 1, buff2, buff_len2 );
3219  }
3220 
3221  STRING( res )[LENGTH( res )] = NULL_CHAR;
3222  RETURN( res );
3223  }
3224 }
3225 
3226 
3227 //===================================================
3237 //===================================================
3238 
3239 atom_t RUNTIME rt_lput( atom_t data2, atom_t data1 )
3240 {
3241  if (IS_ERROR( data1 )) RETURN( USE(data1) );
3242  if (IS_ERROR( data2 )) RETURN( USE(data2) );
3243 
3244  if (IS_LIST( data2 ))
3245  {
3246  RETURN( copy_append( data2, data1 ) );
3247  }
3248  else
3249  {
3251  int buff_len2 = MAX_NUMBER_WORD_LENGTH;
3252 
3254  int buff_len1 = MAX_NUMBER_WORD_LENGTH;
3255 
3256  atom_t res;
3257 
3258  /* check parametr correctness */
3259  if (!IS_ANY_WORD( data2 ) && !atom_to_string( data2, buff2, &buff_len2 ))
3260  {
3261  RETURN( new_error( ERROR_NOT_A_WORD, data2 ) );
3262  }
3263 
3264  if ((IS_ANY_WORD( data1 ) && LENGTH( data1 ) != 1) ||
3265  (!atom_to_string( data1, buff1, &buff_len1 ) || buff_len1 != 1))
3266  {
3268  }
3269 
3270  if (IS_ANY_WORD( data2 ))
3271  {
3272  res = create_word( 1 + LENGTH( data2 ) );
3273  STRNCPY( STRING( res ), STRING( data2 ), LENGTH( data2 ) );
3274  STRING( res )[LENGTH( data2 )] = IS_ANY_WORD( data1 ) ? STRING( data1 )[0] : buff1[0];
3275  }
3276  else
3277  {
3278  res = create_word( 1 + buff_len2 );
3279  STRNCPY( STRING( res ), buff2, buff_len2 );
3280  STRING( res )[buff_len2] = IS_ANY_WORD( data1 ) ? STRING( data1 )[0] : buff1[0];
3281  }
3282 
3283  STRING( res )[LENGTH( res )] = NULL_CHAR;
3284  RETURN( res );
3285  }
3286 }
3287 
3288 
3289 //===================================================
3298 //===================================================
3299 
3300 atom_t RUNTIME rt_count( atom_t data )
3301 {
3303  int buff_len = MAX_NUMBER_WORD_LENGTH;
3304 
3305  if (IS_ERROR( data ))
3306  {
3307  RETURN( USE(data) );
3308  }
3309  if (IS_ANY_WORD( data ))
3310  {
3311  RETURN( new_integer( LENGTH( data ) ) );
3312  }
3313  if (IS_LIST( data ))
3314  {
3315  RETURN( new_integer( list_length( data ) ) );
3316  }
3317  if (atom_to_string( data, buff, &buff_len ))
3318  {
3319  RETURN( new_integer( buff_len ) );
3320  }
3322 }
3323 
3324 
3325 //===================================================
3333 //===================================================
3334 
3335 atom_t RUNTIME rt_char( atom_t data )
3336 {
3337  int64_t x;
3338  char_t str[2];
3339  GET_INT( data, x );
3340 
3341 #ifdef UNICODE_CHARS
3343  {
3344  if (x < 0 || x > ((1 << 16) - 1))
3345  {
3347  }
3348  str[0] = (char_t) x;
3349  str[1] = NULL_CHAR;
3350  RETURN( new_word( str, 1 ) );
3351  }
3352 #endif
3353 
3354  if (x < 0 || x > 255)
3355  {
3357  }
3358 
3359  str[0] = DEBAR( (char_t) x );
3360  str[1] = NULL_CHAR;
3361  RETURN( new_word( str, 1 ) );
3362 }
3363 
3364 
3365 
3366 //===================================================
3374 //===================================================
3375 
3376 atom_t RUNTIME rt_ascii( atom_t data )
3377 {
3379  int buff_len = MAX_NUMBER_WORD_LENGTH;
3380 
3381  if (IS_ERROR( data ))
3382  {
3383  RETURN( USE(data) );
3384  }
3385 
3386  if (IS_ANY_WORD( data ))
3387  {
3388  if (LENGTH( data ) != 1)
3389  {
3391  }
3392 #ifdef UNICODE_CHARS
3393  if (!OPTION_TRADITIONAL)
3394  {
3395  RETURN( new_integer( (ushort_t) DEBAR( STRING( data )[0] ) ) );
3396  }
3397 #endif
3398  RETURN( new_integer( (byte_t) DEBAR( STRING( data )[0] ) ) );
3399  }
3400 
3401  if (IS_LIST( data ))
3402  {
3403  RETURN( new_error( ERROR_NOT_A_WORD, data ) );
3404  }
3405 
3406  if (atom_to_string( data, buff, &buff_len ))
3407  {
3408  if (buff_len == 1)
3409  {
3410 #ifdef UNICODE_CHARS
3411  if (!OPTION_TRADITIONAL)
3412  {
3413  RETURN( new_integer( (ushort_t) DEBAR( buff[0] ) ) );
3414  }
3415 #endif
3416  RETURN( new_integer( (byte_t) DEBAR( buff[0] ) ) );
3417  }
3418 
3419  // Word but too long
3421  }
3422  RETURN( new_error( ERROR_NOT_A_WORD, data ) );
3423 }
3424 
3425 
3426 
3427 //===================================================
3436 //===================================================
3437 
3438 atom_t RUNTIME rt_lower( atom_t data )
3439 {
3440  atom_t res;
3441  int i;
3442 
3443  if (IS_ERROR( data ))
3444  {
3445  RETURN( USE(data) );
3446  }
3447 
3448  if (IS_ANY_WORD( data ))
3449  {
3450  res = new_word( STRING( data ), LENGTH( data ) );
3451  }
3452  else
3453  {
3455  int buff_len = MAX_NUMBER_WORD_LENGTH;
3456 
3457  if (IS_LIST( data ) || !atom_to_string( data, buff, &buff_len ))
3458  {
3459  RETURN( new_error( ERROR_NOT_A_WORD, data ) );
3460  }
3461  // in case of boolean of scientific float mey be necessery to convert
3462  res = new_word( buff, buff_len );
3463  }
3464 
3465  // proces word and make convertion
3466  for (i = 0; i < LENGTH( res ); ++i)
3467  {
3468  STRING( res )[i] = TOLOWER( DEBAR( STRING( res )[i] ) );
3469  }
3470 
3471  RETURN( res );
3472 }
3473 
3474 
3475 //===================================================
3484 //===================================================
3485 
3486 atom_t RUNTIME rt_upper( atom_t data )
3487 {
3488  atom_t res;
3489  int i;
3490 
3491  if (IS_ERROR( data ))
3492  {
3493  RETURN( USE(data) );
3494  }
3495 
3496  if (IS_ANY_WORD( data ))
3497  {
3498  res = new_word( STRING( data ), LENGTH( data ) );
3499  }
3500  else
3501  {
3503  int buff_len = MAX_NUMBER_WORD_LENGTH;
3504 
3505  if (IS_LIST( data ) || !atom_to_string( data, buff, &buff_len ))
3506  {
3507  RETURN( new_error( ERROR_NOT_A_WORD, data ) );
3508  }
3509  // in case of boolean of scientific float mey be necessery to convert
3510  res = new_word( buff, buff_len );
3511  }
3512 
3513  // proces word and make convertion
3514  for (i = 0; i < LENGTH( res ); ++i)
3515  {
3516  STRING( res )[i] = TOUPPER( DEBAR( STRING( res )[i] ) );
3517  }
3518 
3519  RETURN( res );
3520 }
3521 
3522 
3523 //===================================================
3538 //===================================================
3539 
3540 atom_t RUNTIME rt_member( atom_t cip, atom_t data, atom_t elem )
3541 {
3542  if (IS_ERROR( data ))
3543  {
3544  RETURN( USE(data) );
3545  }
3546 
3547  if (IS_LIST( data ))
3548  { // Test all elements of the list for equality with elem
3549  while (!IS_EMPTY( data ))
3550  {
3551  if (atom_equal( cip, CAR( data ), elem ))
3552  RETURN( USE( data ) );
3553  data = CDR( data );
3554  }
3555  RETURN( USE( empty_list ) );
3556  }
3557  else
3558  {
3560  chars_t comp_buffer;
3561  int buff_len = MAX_NUMBER_WORD_LENGTH; // We start with 3 symbols. Actually need 1, but test if there is more
3562  int pos;
3563  char_t elem_ch;
3564 
3565  // If data is not a list, elem must be one character word
3566  if (IS_ANY_WORD( elem ) && LENGTH( elem ) != 1)
3567  {
3569  }
3570  if (!IS_ANY_WORD( elem ) && (!atom_to_string( elem, buff, &buff_len ) || buff_len != 1))
3571  {
3573  }
3574 
3575  if (buff_len == 1) // elem is one char word -> Store it
3576  {
3577  elem_ch = DEBAR( buff[0] );
3578  }
3579  else
3580  {
3581  elem_ch = DEBAR( STRING( elem )[0] );
3582  }
3583 
3584  if (IS_ANY_WORD( data ))
3585  {
3586  comp_buffer = STRING( data );
3587  buff_len = LENGTH( data );
3588  }
3589  else
3590  {
3591  buff_len = MAX_NUMBER_WORD_LENGTH;
3592  if (!atom_to_string( data, buff, &buff_len ) || buff_len == 0)
3593  {
3594  RETURN( new_error( ERROR_NOT_A_WORD, data ) );
3595  }
3596  comp_buffer = buff;
3597  }
3598  pos = 0;
3599  while (pos < buff_len)
3600  {
3601  if (DEBAR( comp_buffer[pos] ) == elem_ch)
3602  {
3603  if (IS_ANY_WORD( data ))
3604  {
3605  RETURN( new_subword( data, comp_buffer + pos, buff_len - pos ) );
3606  }
3607  else
3608  {
3609  RETURN( new_word( comp_buffer + pos, buff_len - pos ) );
3610  }
3611  }
3612  ++pos;
3613  }
3614  RETURN( new_word( buff, 0 ) );
3615  }
3616 }
3617 
3618 
3619 //===================================================
3629 //===================================================
3630 
3631 atom_t RUNTIME rt_iseq( atom_t to, atom_t from )
3632 {
3633  int64_t first;
3634  int64_t last;
3635  atom_t list_start, list_end;
3636 
3637  GET_INT( from, first );
3638  GET_INT( to, last );
3639 
3640  list_start = list_end = empty_list;
3641  if (first > last)
3642  {
3643  for (; first >= last; --first)
3644  append( new_integer( first ), &list_start, &list_end );
3645  }
3646  else
3647  {
3648  for (; first <= last; ++first)
3649  append( new_integer( first ), &list_start, &list_end );
3650  }
3651  RETURN( list_start );
3652 }
3653 
3654 
3655 //===================================================
3666 //===================================================
3667 
3668 atom_t RUNTIME rt_rseq( atom_t count, atom_t to, atom_t from )
3669 {
3670  float64_t first;
3671  float64_t last;
3672  float64_t step;
3673  int64_t cnt;
3674 
3675  atom_t list_start, list_end;
3676 
3677  GET_FLOAT( from, first );
3678  GET_FLOAT( to, last );
3679  GET_INT( count, cnt );
3680 
3681  if (cnt <= 0 || (cnt == 1 && first != last))
3682  {
3684  }
3685 
3686  list_start = list_end = empty_list;
3687  if (first > last)
3688  {
3689  for (step = cnt > 1 ? (first - last) / (cnt - 1) : 0; cnt > 0; --cnt, first -= step)
3690  {
3691  append( new_float( first ), &list_start, &list_end );
3692  }
3693  }
3694  else
3695  {
3696  for (step = cnt > 1 ? (last - first) / (cnt - 1) : 0; cnt > 0; --cnt, first += step)
3697  {
3698  append( new_float( first ), &list_start, &list_end );
3699  }
3700  }
3701  RETURN( list_start );
3702 }
3703 
3704 
3705 //===================================================
3720 //===================================================
3721 
3722 atom_t RUNTIME rt_random( int count, atom_t data2, atom_t data1 )
3723 {
3724  int rand_num = rand( );
3725  if (count == 1)
3726  {
3727  if (!OPTION_TRADITIONAL && IS_LIST( data2 ))
3728  {
3729  int len;
3730  if (IS_EMPTY( data2 ))
3731  {
3733  }
3734 
3735  len = list_length( data2 );
3736  RETURN( USE( get_at_list( data2, rand_num % len ) ) );
3737  }
3738  else
3739  {
3740  int64_t num;
3741  GET_INT( data2, num );
3742 
3743  if (num <= 0)
3744  {
3746  }
3747  RETURN( new_integer( rand_num % num ) );
3748  }
3749  }
3750  else if (count == 2)
3751  {
3752  int64_t start;
3753  int64_t end;
3754 
3755  GET_INT( data1, start );
3756  GET_INT( data2, end );
3757 
3758  if (start > end || start < 0)
3759  {
3761  }
3762  RETURN( new_integer( rand_num % (end - start + 1) + start ) );
3763  }
3764  else
3765  {
3767  }
3768 }
3769 
3770 
3771 //===================================================
3779 //===================================================
3780 
3781 atom_t RUNTIME rt_rerandom( int count, atom_t seed )
3782 {
3783  int64_t rseed;
3784  if (count == 1)
3785  {
3786  GET_INT( seed, rseed );
3787  }
3788  else if (count == 0)
3789  {
3790  rseed = 0;
3791  }
3792  else
3793  {
3795  }
3796 
3797  srand( (uint_t) rseed );
3798  RETURN( unbound );
3799 }
3800 
3801 
3802 //===================================================
3815 //===================================================
3816 
3817 atom_t RUNTIME rt_show( atom_t pdl, atom_t pwl, atom_t fpp, int data )
3818 {
3819  // check print-related variabples
3822  atom_to_boolean( fpp, &full_print_p );
3823 
3824  // do the actual print
3825  atom_t ARGUMENT;
3826  for (EACH_ARGUMENT)
3827  {
3828  if (IS_ERROR( ARGUMENT ))
3829  {
3830  RETURN( USE(ARGUMENT) );
3831  }
3832 
3833  // If list adds square brackets
3834  if (IS_LIST( ARGUMENT ))
3835  {
3836  outter( TEXT( "[" ), 1 );
3837  dump( ARGUMENT );
3838  outter( TEXT( "]" ), 1 );
3839  }
3840  else
3841  {
3842  dump( ARGUMENT );
3843  }
3844  outter( TEXT( " " ), 1 );
3845  }
3846 
3847  outter( TEXT( "\n" ), 1 );
3848  RETURN( unbound );
3849 }
3850 
3851 
3852 //===================================================
3865 //===================================================
3866 
3867 atom_t RUNTIME rt_type( atom_t pdl, atom_t pwl, atom_t fpp, int data )
3868 {
3869  // check print-related variabples
3872  atom_to_boolean( fpp, &full_print_p );
3873 
3874  // do the actual print
3875  atom_t ARGUMENT;
3876  for (EACH_ARGUMENT)
3877  {
3878  if (IS_ERROR( ARGUMENT ))
3879  {
3880  RETURN( USE(ARGUMENT) );
3881  }
3882  dump( ARGUMENT );
3883  }
3884  RETURN( unbound );
3885 }
3886 
3887 
3888 //===================================================
3901 //===================================================
3902 
3903 atom_t RUNTIME rt_form( atom_t precision, atom_t width, atom_t num )
3904 {
3905  int64_t num_prec;
3906  int64_t num_width;
3907  float64_t number;
3908 
3909  chars_t format;
3911  int buff_len = MAX_WORD_LENGTH;
3912 
3913  GET_FLOAT( num, number );
3914  GET_INT( precision, num_prec );
3915  if (num_prec >= 0)
3916  {
3917  GET_INT( width, num_width );
3918  format = TEXT( "%*.*lf" );
3919  SPRINT( buff, buff_len, format, (uint_t) num_width, (uint_t) num_prec, number );
3920  }
3921  else
3922  {
3923  if (IS_ANY_WORD( width ))
3924  {
3925  format = STRING( width );
3926  SPRINTF( buff, buff_len, format, number );
3927  }
3928  else
3929  {
3930  RETURN( new_error( ERROR_NOT_A_WORD, width ) );
3931  }
3932  }
3933 
3934  buff_len = STRLEN( buff );
3935  RETURN( new_word( buff, buff_len ) );
3936 }
3937 
3938 
3939 //===================================================
3947 //===================================================
3948 
3949 char_t RUNTIME get_format( chars_t string )
3950 {
3951  chars_t elem = string;
3952  char_t type = 0;
3953  while (elem)
3954  {
3955  elem = STRCHR( elem, TEXT( '%' ) );
3956  if (elem)
3957  {
3958  ++elem;
3959  if (elem[0] == TEXT( '%' ))
3960  {
3961  elem += 1;
3962  }
3963  else
3964  {
3965  while (ISDIGIT( *elem ) || *elem == TEXT( '.' ))
3966  {
3967  ++elem;
3968  }
3969  while (*elem == TEXT( 'l' ) || *elem == TEXT( 'u' ) || *elem == TEXT( 'h' ))
3970  ++elem;
3971  }
3972  if (type) return 0;
3973  type = *elem;
3974  }
3975  }
3976  return type;
3977 }
3978 
3979 
3980 //===================================================
3990 //===================================================
3991 
3992 atom_t RUNTIME rt_format( atom_t format, atom_t data )
3993 {
3994  if (!IS_ANY_WORD( format ))
3995  {
3996  RETURN( new_error( ERROR_NOT_A_WORD, format ) );
3997  }
3998  else
3999  {
4000  char_t buff[MAX_WORD_LENGTH];
4001  int buff_len = MAX_WORD_LENGTH;
4002  char_t end = STRING( format )[LENGTH( format )];
4003 
4004  STRING( format )[LENGTH( format )] = NULL_CHAR;
4005  char_t format_chr = get_format( STRING( format ) );
4006 
4007  switch (format_chr)
4008  {
4009  // Integer number
4010  case TEXT( 'd' ) : case TEXT( 'i' ) : case TEXT( 'u' ) :
4011 
4012  case TEXT( 'x' ) : case TEXT( 'X' ) : case TEXT( 'o' ) :
4013  {
4014  int64_t i_num;
4015  STRING( format )[LENGTH( format )] = end;
4016  GET_INT( data, i_num );
4017  STRING( format )[LENGTH( format )] = NULL_CHAR;
4018  SPRINTF( buff, buff_len, STRING( format ), i_num );
4019  break;
4020  }
4021  // Floating point number
4022  case TEXT( 'f' ) :
4023  case TEXT( 'e' ) : case TEXT( 'E' ) :
4024  case TEXT( 'g' ) : case TEXT( 'G' ) :
4025 
4026  case TEXT( 'a' ) : case TEXT( 'A' ) :
4027  {
4028  float64_t fl_num;
4029  STRING( format )[LENGTH( format )] = end;
4030  GET_FLOAT( data, fl_num );
4031  STRING( format )[LENGTH( format )] = NULL_CHAR;
4032  SPRINTF( buff, buff_len, STRING( format ), fl_num );
4033  break;
4034  }
4035 
4036  // char
4037 
4038  case TEXT( 'c' ) : case TEXT( 'C' ) :
4039  {
4040  char_t ch;
4041  if (IS_ANY_WORD( data ))
4042  {
4043  if (LENGTH( data ) == 0)
4044  {
4045  STRING( format )[LENGTH( format )] = end;
4046  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
4047  }
4048  ch = STRING( data )[0];
4049  }
4050  else
4051  if (atom_to_string( data, buff, &buff_len ))
4052  {
4053  if (buff_len == 0)
4054  {
4055  STRING( format )[LENGTH( format )] = end;
4056  RETURN( new_error( ERROR_MISSING_VALUE, data ) );
4057  }
4058  ch = buff[0];
4059  }
4060  else
4061  {
4062  STRING( format )[LENGTH( format )] = end;
4063  RETURN( new_error( ERROR_NOT_A_WORD, data ) );
4064  }
4065  buff_len = MAX_WORD_LENGTH;
4066  SPRINTF( buff, buff_len, STRING( format ), ch );
4067  break;
4068  }
4069 
4070  // string
4071 
4072  case TEXT( 's' ) : case TEXT( 'S' ) :
4073  {
4074  if (IS_ANY_WORD( data ))
4075  {
4076  char_t term = STRING( data )[LENGTH( data )];
4077  STRING( data )[LENGTH( data )] = NULL_CHAR;
4078  SPRINTF( buff, buff_len, STRING( format ), STRING( data ) );
4079  STRING( data )[LENGTH( data )] = term;
4080  }
4081  else
4082  {
4083  char_t num_buff[MAX_NUMBER_WORD_LENGTH];
4084  int num_buff_len;
4085 
4086  if (atom_to_string( data, num_buff, &num_buff_len ))
4087  {
4088  SPRINTF( buff, buff_len, STRING( format ), num_buff );
4089  }
4090  else
4091  {
4092  STRING( format )[LENGTH( format )] = end;
4093  RETURN( new_error( ERROR_NOT_A_WORD, data ) );
4094  }
4095  }
4096  break;
4097  }
4098  // pointer
4099 
4100  case TEXT( 'p' ) :
4101  {
4102  SPRINTF( buff, buff_len, STRING( format ), data );
4103  break;
4104  }
4105  default:
4106  {
4107  STRING( format )[LENGTH( format )] = end;
4109  }
4110  }
4111 
4112  STRING( format )[LENGTH( format )] = end;
4113  buff_len = STRLEN( buff );
4114  RETURN( new_word( buff, buff_len ) );
4115  }
4116 }
4117 
4118 
4119 
4120 //===================================================
4131 //===================================================
4132 
4133 atom_t RUNTIME rt_formattime( atom_t format, atom_t data )
4134 {
4135  atom_t res = unbound;
4136 
4137  CHECK_PARAM(format);
4138  CHECK_PARAM(data);
4139 
4140  if (!IS_ANY_WORD( format ))
4141  {
4142  RETURN( new_error( ERROR_NOT_A_WORD, format ) );
4143  }
4144 
4145  int64_t time64;
4146  if( !atom_to_int( data, &time64 ) )
4147  {
4149  }
4150  time_t time = time64;
4151 
4152  atom_t formatz = atom_to_real_word( format );
4153 
4154  struct tm *presult;
4155  presult = gmtime( &time );
4156  char_t buf[MAX_WORD_LENGTH];
4157  int len;
4158  if( presult )
4159  len = STRFTIME( buf, MAX_WORD_LENGTH, STRING(formatz), presult );
4160  else
4161  len = 0;
4162 
4163  res = new_word( buf, len );
4164  DEUSE( formatz );
4165 
4166  RETURN( res );
4167 }
4168 
4169 
4170 
4171 //===================================================
4182 //===================================================
4183 
4184 atom_t RUNTIME rt_definedp( int static_link, atom_t parent, atom_t data )
4185 {
4186  atom_t word = atom_to_word( data );
4187  if (IS_ERROR( data )) RETURN( USE(data) );
4188 
4189  //printf("looking for "); dump(word); printf(" in "); dumpln(NAME(parent));
4190  atom_t var = find_var( word, parent );
4191  DEUSE( word );
4192  RETURN( USE( false_true[ var && !IS_PRIMITIVE( var ) && !IS_VARIABLE( var ) ] ) );
4193 }
4194 
4195 
4196 
4197 
4198 //===================================================
4209 //===================================================
4210 
4211 atom_t RUNTIME rt_primitivep( int static_link, atom_t parent, atom_t data )
4212 {
4213  atom_t word = atom_to_word( data );
4214  if (IS_ERROR( data )) RETURN( USE(data) );
4215 
4216  atom_t var = find_var( word, parent );
4217  DEUSE( word );
4219  RETURN( USE( false_true[ var && IS_PRIMITIVE( var ) && !IS_VARIABLE( var ) ] ) );
4220 }
4221 
4222 
4223 
4224 
4225 //===================================================
4236 //===================================================
4237 
4238 atom_t RUNTIME rt_namep( int static_link, atom_t parent, atom_t data )
4239 {
4240  atom_t word = atom_to_word( data );
4241  if (IS_ERROR( data )) RETURN( USE(data) );
4242 
4243  atom_t var = find_var( word, parent );
4244  DEUSE( word );
4246  if( !var ) RETURN( USE(false_true[0]) );
4247  if( !IS_VARIABLE(var) ) RETURN( USE(false_true[0]) );
4248 
4249  atom_t value;
4250 
4251  // is primitive variable
4252  if( IS_RUNTIME(var) )
4253  value = VALUE(var);
4254  else
4255  value = rt_var_value( static_link, parent, var );
4256 
4257  RETURN( USE( false_true[!IS_UNBOUND(value)] ) );
4258 }
4259 
4260 
4261 
4262 
4263 //===================================================
4274 //===================================================
4275 
4276 atom_t RUNTIME rt_procedurep( int static_link, atom_t parent, atom_t data )
4277 {
4278  atom_t word = atom_to_word( data );
4279  if (IS_ERROR( data )) RETURN( USE(data) );
4280 
4281  atom_t var = find_var( word, parent );
4282  DEUSE( word );
4284  RETURN( USE( false_true[ var && (IS_FUNCTION( var ) || IS_COMMAND( var )) ] ) );
4285 }
4286 
4287 
4288 
4289 
4290 //===================================================
4301 //===================================================
4302 
4303 atom_t rt_var_value( int static_link, atom_t parent, atom_t var )
4304 {
4305  if (IS_GLOBAL( var )) return ( VALUE( var ));
4306  int i;
4307  for (i = 0; i < LEVEL( parent ) - LEVEL( var ) + 1; i++)
4308  static_link = *(int*) ((char*) static_link + BASE_OFFSET_STATIC);
4309 
4310  return *(atom_t*) ((char*) static_link + OFFSET( var ));
4311 }
4312 
4313 
4314 
4315 //===================================================
4326 //===================================================
4327 
4328 void rt_set_var_value( int static_link, atom_t parent, atom_t var, atom_t value )
4329 {
4330  //printf("in rt_set_var_value\n");
4331  //printf("var="); dumpln(var);
4332  //printf("parent="); dumpln(PARENT(var));
4333  //printf("is primitive=%d\n",IS_PRIMITIVE(var));
4334  //printf("is global=%d\n",IS_GLOBAL(var));
4335  //printf("is runtime=%d\n",IS_RUNTIME(var));
4336 
4337  if (IS_RUNTIME( var ))
4338  {
4339  //printf("VALUE IS VAR ATOM\n");
4340  //printf("var = "); dumpln(var);
4341  //printf("old value="); dumpln(VALUE(var));
4342  //printf("new value="); dumpln(value);
4343  DEUSE( VALUE( var ) );
4344  VALUE( var ) = USE( value );
4345  //printf("new value="); dumpln(VALUE(var));
4346  return;
4347  }
4348 
4349  //printf("VALUE IN STACK\n");
4350  int i;
4351  for (i = 0; i < LEVEL( parent ) - LEVEL( var ) + 1; i++)
4352  static_link = *(int*) ((char*) static_link + BASE_OFFSET_STATIC);
4353 
4354  atom_t* varptr = (atom_t*) ((char*) static_link + OFFSET( var ));
4355  DEUSE( *varptr );
4356  *varptr = USE( value );
4357 }
4358 
4359 
4360 
4361 //===================================================
4372 //===================================================
4373 #define rt_use_var __attribute__((used,noinline,regparm(0),stdcall)) rt_use_var
4374 
4375 atom_t rt_use_var( atom_t source, atom_t value )
4376 #undef rt_use_var
4377 {
4378  //printf("rt_use_var="); dumpln(value);
4379  //printf(" source="); dumpln(source);
4380  if (IS_UNBOUND( value ))
4381  {
4383  }
4384  //printf("------------\n");
4385  RETURN( USE( value ) );
4386 }
4387 
4388 
4389 
4390 //===================================================
4401 //===================================================
4402 
4403 atom_t RUNTIME rt_thing( int static_link, atom_t parent, atom_t data )
4404 {
4405  if (IS_ERROR( data )) RETURN( USE(data) );
4406 
4407  atom_t word = atom_to_word( data );
4408  if (IS_ERROR( word )) RETURN( word );
4409 
4410  atom_t var = find_runtime_var( word, static_link );
4411  DEUSE( word );
4412 
4413  // not found
4414  if (!var)
4415  RETURN( new_error( ERROR_UNKNOWN_VAR, data ) );
4416 
4417  // not a variable (i.e. it is a function or a procedure)
4418  if (!IS_VARIABLE( var ))
4419  RETURN( new_error( ERROR_NOT_A_VAR, data ) );
4420 
4421  // is primitive variable
4422  if (IS_RUNTIME( var ))
4423  RETURN( USE( VALUE( var ) ) );
4424 
4425  // user-defined variable
4426  RETURN( USE( rt_var_value( static_link, parent, var ) ) );
4427 }
4428 
4429 
4430 //===================================================
4441 //===================================================
4442 
4443 atom_t RUNTIME rt_reference( int static_link, atom_t parent, atom_t data )
4444 {
4445  //printf("rt_reference = "); dumpln(data);
4446 
4447  if (IS_ERROR( data )) RETURN( USE( data ) );
4448 
4449  atom_t word = atom_to_word( data );
4450  if (IS_ERROR( word )) RETURN( word );
4451 
4452  atom_t real_name = new_subword( word, STRING( word ) + 1, LENGTH( word ) - 1 );
4453  //printf("~~~~~~searching for var=");dumpln(real_name);
4454  atom_t var = find_runtime_var( real_name, static_link );
4455  if (IS_UNBOUND( var )) var = find_var( real_name, parent );
4456  DEUSE( real_name );
4457  DEUSE( word );
4458 
4459  //if( var )
4460  //{
4461  //printf("~~~~~~3~~~~~~ found var=(%x)",(int)var); dumpln(var);
4462  //printf(" its parent is="); dumpln(PARENT(var));
4463  //}
4464  //else
4465  //{
4466  //printf("~~~~~~3~~~~~~ not found\n");
4467  //}
4468 
4469  // not found
4470  if (!var)
4471  RETURN( new_error( ERROR_UNKNOWN_VAR, data ) );
4472 
4473  // not a variable (i.e. it is a function or a procedure)
4474  if (!IS_VARIABLE( var ))
4475  RETURN( new_error( ERROR_NOT_A_VAR, data ) );
4476 
4477  // is primitive variable
4478  if (IS_RUNTIME( var ))
4479  {
4480  //printf("var="); dumpln(var);
4481  RETURN( USE( VALUE( var ) ) );
4482  }
4483 
4484  //printf("value="); dumpln(VALUE(var));
4485 
4486  // user-defined variable
4487  RETURN( USE( rt_var_value( static_link, parent, var ) ) );
4488 }
4489 
4490 
4491 //===================================================
4500 //===================================================
4501 
4502 #define rt_check_inputs __attribute__((used,noinline,regparm(0),stdcall)) rt_check_inputs
4503 
4504 atom_t rt_check_inputs( int stack_frame )
4505 #undef rt_check_inputs
4506 {
4507  atom_t res = unbound;
4508  int inputs = *(int*)(stack_frame+BASE_OFFSET_PARAMSCOUNT);
4509  //printf("inputs=%d\n",inputs);
4510  for( ; inputs>0; inputs-- )
4511  {
4512  atom_t data = *(atom_t*)(stack_frame+BASE_OFFSET_PARAMSCOUNT+4*inputs);
4513  if( IS_ERROR(data) )
4514  {
4515  data = USE(data);
4516  if( res==unbound ) res = data;
4517  }
4518  }
4519  RETURN( res );
4520 }
4521 
4522 
4523 //===================================================
4528 //===================================================
4529 
4530 atom_t RUNTIME rt_bye( void )
4531 {
4532  //exit(0);
4534 }
4535 
4536 
4537 //===================================================
4545 //===================================================
4546 
4547 atom_t RUNTIME rt_wait( atom_t time )
4548 {
4549  int64_t wait_time;
4550  GET_INT( time, wait_time );
4551 
4552  fflush( stdout ); // Flushing output buffer
4553 
4554  if (wait_time > 0)
4555  {
4556 #ifdef WINDOWS
4557  wait_time = (wait_time * 1000) / 60; // convert 60-ths of second to milliseconds
4558  Sleep( wait_time );
4559 #else
4560  wait_time = (wait_time * 1000 * 1000) / 60; // convert 60-ths of second to milliseconds
4561  usleep( wait_time );
4562 #endif
4563  }
4564  RETURN( unbound );
4565 }
4566 
4567 
4568 //===================================================
4579 //===================================================
4580 
4581 atom_t RUNTIME rt_ashift( atom_t bits, atom_t num )
4582 {
4583  int64_t number;
4584  int64_t bits_num;
4585 
4586  GET_INT( bits, bits_num );
4587  GET_INT( num, number );
4589  if (bits_num < 0)
4590  {
4591  RETURN( new_integer( number >> -bits_num ) );
4592  }
4593  else
4594  {
4595  RETURN( new_integer( number << bits_num ) );
4596  }
4597 }
4598 
4599 
4600 //===================================================
4611 //===================================================
4612 
4613 atom_t RUNTIME rt_lshift( atom_t bits, atom_t num )
4614 {
4615  int64_t number;
4616  int64_t bits_num;
4617 
4618  GET_INT( bits, bits_num );
4619  GET_INT( num, number );
4621  if (bits_num < 0)
4622  {
4623  RETURN( new_integer( (int64_t) (((uint64_t) number) >> -bits_num) ) );
4624  }
4625  else
4626  {
4627  RETURN( new_integer( number << bits_num ) );
4628  }
4629 }
4630 
4631 
4632 //===================================================
4641 //===================================================
4642 
4643 atom_t RUNTIME rt_bitand( int data )
4644 {
4645  int64_t acc = -1;
4646  int64_t x;
4647  atom_t ARGUMENT;
4648 
4649  for (EACH_ARGUMENT) // Process each given argument
4650  {
4651  GET_INT( ARGUMENT, x );
4652  acc &= x;
4653  }
4654  RETURN( new_integer( acc ) );
4655 }
4656 
4657 
4658 //===================================================
4667 //===================================================
4668 
4669 atom_t RUNTIME rt_bitor( int data )
4670 {
4671  int64_t acc = 0;
4672  int64_t x;
4673  atom_t ARGUMENT;
4674 
4675  for (EACH_ARGUMENT) // Process each given argument
4676  {
4677  GET_INT( ARGUMENT, x );
4678  acc |= x;
4679  }
4680  RETURN( new_integer( acc ) );
4681 }
4682 
4683 
4684 
4685 //===================================================
4695 //===================================================
4696 
4697 atom_t RUNTIME rt_bitxor( int data )
4698 {
4699  int64_t acc = 0;
4700  int64_t x;
4701  atom_t ARGUMENT;
4702 
4703  for (EACH_ARGUMENT) // Process each given argument
4704  {
4705  GET_INT( ARGUMENT, x );
4706  acc ^= x;
4707  }
4708  RETURN( new_integer( acc ) );
4709 }
4710 
4711 
4712 //===================================================
4721 //===================================================
4722 
4724 {
4725  int64_t x;
4726  GET_INT( data, x );
4727 
4728  RETURN( new_integer(~x ) );
4729 }
4731 
4732 //===================================================
4740 //===================================================
4741 
4742 atom_t RUNTIME rt_pick( atom_t list )
4743 {
4744  if (IS_ERROR( list ))
4745  {
4746  RETURN( USE(list) );
4747  }
4748  if (IS_LIST( list ))
4749  {
4750  int len;
4751  int rand_num;
4752  if (IS_EMPTY( list ))
4753  {
4755  }
4756  rand_num = rand( );
4757  len = list_length( list );
4758  RETURN( USE( get_at_list( list, rand_num % len ) ) );
4759  }
4760  RETURN( new_error( ERROR_NOT_A_LIST, list ) );
4761 }
4762 
4763 
4764 //===================================================
4774 //===================================================
4775 
4776 atom_t RUNTIME rt_remdup( atom_t cip, atom_t data )
4777 {
4778  atom_t result;
4779 
4780  if (IS_ERROR(data))
4781  {
4782  RETURN(USE(data));
4783  }
4784 
4785  if (IS_LIST(data))
4786  {
4787  atom_t iter;
4788  atom_t res_iter;
4789 
4790  result = empty_list;
4791  res_iter = result;
4792 
4793  while (!IS_EMPTY(data))
4794  {
4795  iter = CDR(data);
4796  while (!IS_EMPTY(iter))
4797  {
4798  if (atom_equal( cip, CAR(data), CAR( iter ) ))
4799  {
4800  break;
4801  }
4802  iter = CDR( iter );
4803  }
4804  if (IS_EMPTY( iter ))
4805  {
4806  if (IS_EMPTY( res_iter ))
4807  {
4808  result = res_iter = new_list( USE( CAR(data) ), empty_list );
4809  }
4810  else
4811  {
4812  CDR( res_iter ) = new_list( USE( CAR(data) ), empty_list );
4813  res_iter = CDR( res_iter );
4814  }
4815  }
4816  data = CDR(data);
4817  }
4818  }
4819  else // Data is a WORD
4820  {
4821  size_t len, total;
4822  size_t i, j;
4823  int case_ignore;
4824  chars_t word;
4825  atom_t data1;
4826  if (!atom_to_boolean( cip, &case_ignore ))
4827  {
4828  case_ignore = 1;
4829  }
4830  data1 = atom_to_word(data);
4831  if (IS_ERROR(data1))
4832  {
4833  RETURN(data1);
4834  }
4835 
4836  total = len = LENGTH(data1);
4837  word = STRING(data1);
4838  if (case_ignore)
4839  {
4840  for (i = 0; i < total-1; ++i)
4841  {
4842  for (j = i+1; j < total; ++j)
4843  {
4844  if (TOLOWER(DEBAR(word[i]))==TOLOWER(DEBAR(word[j])))
4845  {
4846  --len;
4847  break;
4848  }
4849  }
4850  }
4851  result = create_word(len);
4852  len = 0;
4853  for (i = 0; i < total; ++i)
4854  {
4855  for (j = i+1; j < total; ++j)
4856  {
4857  if (TOLOWER(DEBAR(word[i]))==TOLOWER(DEBAR(word[j])))
4858  {
4859  break;
4860  }
4861  }
4862  if (j >= total)
4863  {
4864  STRING(result)[len++] = word[i];
4865  }
4866  }
4867  }
4868  else
4869  {
4870  for (i = 0; i < total-1; ++i)
4871  {
4872  for (j = i+1; j < total; ++j)
4873  {
4874  if (DEBAR(word[i])==DEBAR(word[j]))
4875  {
4876  --len;
4877  break;
4878  }
4879  }
4880  }
4881  result = create_word(len);
4882  len = 0;
4883  for (i = 0; i < total; ++i)
4884  {
4885  for (j = i+1; j < total; ++j)
4886  {
4887  if (DEBAR(word[i])==DEBAR(word[j]))
4888  {
4889  break;
4890  }
4891  }
4892  if (j >= total)
4893  {
4894  STRING(result)[len++] = word[i];
4895  }
4896  }
4897  }
4898  DEUSE(data1);
4899  }
4900  RETURN(result);
4901 }
4902 
4903 
4904 //===================================================
4915 //===================================================
4916 
4917 atom_t RUNTIME rt_remove( atom_t cip, atom_t data, atom_t elem )
4918 {
4919  atom_t result;
4920  atom_t res_iter;
4921 
4922  if (IS_ERROR( data ))
4923  {
4924  RETURN( USE(data) );
4925  }
4926 
4927  if (IS_LIST(data))
4928  {
4929  result = empty_list;
4930  res_iter = result;
4931 
4932  while (!IS_EMPTY( data ))
4933  {
4934  if (!atom_equal( cip, CAR( data ), elem ))
4935  {
4936  if (IS_EMPTY( res_iter ))
4937  {
4938  result = res_iter = new_list( USE( CAR( data ) ), empty_list );
4939  }
4940  else
4941  {
4942  CDR( res_iter ) = new_list( USE( CAR( data ) ), empty_list );
4943  res_iter = CDR( res_iter );
4944  }
4945  }
4946  data = CDR( data );
4947  }
4948  }
4949  else // data is a word
4950  {
4951  size_t len, total;
4952  size_t i;
4953  int case_ignore;
4954  chars_t word;
4955  atom_t data1;
4956  char_t ch;
4957  if (IS_ERROR(elem))
4958  {
4959  RETURN(USE(elem));
4960  }
4961 
4962  data1 = atom_to_word(elem);
4963  if (IS_ERROR(data1) || LENGTH(data1) != 1)
4964  {
4965  DEUSE(data1);
4967  }
4968  ch = (STRING(data1))[0];
4969  DEUSE(data1);
4970 
4971  if (!atom_to_boolean( cip, &case_ignore ))
4972  {
4973  case_ignore = 1;
4974  }
4975  data1 = atom_to_word(data);
4976  if (IS_ERROR(data1))
4977  {
4978  DEUSE(data1);
4979  RETURN(data);
4980  }
4981  total = len = LENGTH(data1);
4982  word = STRING(data1);
4983  if (case_ignore)
4984  {
4985  ch = TOLOWER(DEBAR(ch));
4986  for (i = 0; i < total; ++i)
4987  {
4988  if (TOLOWER(DEBAR(word[i]))==ch)
4989  {
4990  --len;
4991  }
4992  }
4993  result = create_word(len);
4994  len = 0;
4995  for (i = 0; i < total; ++i)
4996  {
4997  if (TOLOWER(DEBAR(word[i]))!=ch)
4998  {
4999  STRING(result)[len++] = word[i];
5000  }
5001  }
5002  }
5003  else
5004  {
5005  ch = DEBAR(ch);
5006  for (i = 0; i < total; ++i)
5007  {
5008  if (DEBAR(word[i])==ch)
5009  {
5010  --len;
5011  }
5012  }
5013  result = create_word(len);
5014  len = 0;
5015  for (i = 0; i < total; ++i)
5016  {
5017  if (DEBAR(word[i])!=ch)
5018  {
5019  STRING(result)[len++] = word[i];
5020  }
5021  }
5022  }
5023  DEUSE(data1);
5024  }
5025  RETURN(result);
5026 }
5027 
5028 
5029 //===================================================
5037 //===================================================
5038 
5040 {
5041  atom_t result;
5042 
5043  if (IS_ERROR( data ))
5044  {
5045  RETURN( USE(data) );
5046  }
5047 
5048  if (IS_LIST(data))
5049  {
5050  if (IS_EMPTY( data ))
5051  {
5052  RETURN( data );
5053  }
5054 
5055  result = empty_list;
5056  while (!IS_EMPTY( data ))
5057  {
5058  result = new_list( USE( CAR( data ) ), result );
5059  data = CDR( data );
5060  }
5061  }
5062  else // data must be word
5063  {
5064  int i, n;
5065  data = atom_to_word( data );
5066  if (IS_ERROR( data ))
5067  {
5068  RETURN( data );
5069  }
5070  result = create_word(LENGTH( data ));
5071  n = LENGTH( data );
5072  for (i = 0; i < n; ++i)
5073  {
5074  STRING( result )[n - i - 1] = STRING( data )[i];
5075  }
5076  DEUSE (data);
5077  }
5078 
5079  RETURN( result );
5080 }
5081 
5082 
5083 //===================================================
5092 //===================================================
5093 
5095 {
5097  int buff_len = MAX_NUMBER_WORD_LENGTH;
5098 
5099  if (IS_ERROR( data ))
5100  {
5101  RETURN( USE(data) );
5102  }
5103 
5104  if (IS_ANY_WORD( data ))
5105  {
5106  if (LENGTH( data ) != 1)
5107  {
5109  }
5110 #ifdef UNICODE_CHARS
5111  if (!OPTION_TRADITIONAL)
5112  {
5113  RETURN( new_integer( (ushort_t) STRING( data )[0] ) );
5114  }
5115 #endif
5116  RETURN( new_integer( (byte_t) STRING( data )[0] ) );
5117  }
5118 
5119  if (IS_LIST( data ))
5120  {
5121  RETURN( new_error( ERROR_NOT_A_WORD, data ) );
5122  }
5123 
5124  if (atom_to_string( data, buff, &buff_len ))
5125  {
5126  if (buff_len == 1)
5127  {
5128 #ifdef UNICODE_CHARS
5129  if (!OPTION_TRADITIONAL)
5130  {
5131  RETURN( new_integer( (ushort_t) buff[0] ) );
5132  }
5133 #endif
5134  RETURN( new_integer( (byte_t) buff[0] ) );
5135  }
5136 
5137  // Word but too long
5139  }
5140  RETURN( new_error( ERROR_NOT_A_WORD, data ) );
5141 }
5142 
5143 
5144 //===================================================
5152 //===================================================
5153 
5155 {
5156  static int num = 1;
5157  int num_len, temp, temp_len;
5159 
5160  sym[0] = TEXT( 'G' );
5162  num_len = (int) log10( num ) + 1;
5163  sym[num_len + 1] = NULL_CHAR;
5164 
5165  for (temp = num, temp_len = num_len; temp_len > 0; --temp_len, temp /= 10)
5166  {
5167  sym[temp_len] = TEXT( '0' ) + temp % 10;
5168  }
5169  ++num;
5170  RETURN( new_word( sym, num_len + 1 ) );
5171 }
5172 
5173 
5174 //===================================================
5185 //===================================================
5186 
5187 atom_t RUNTIME rt_substringp( atom_t cip, atom_t data2, atom_t data1 )
5188 {
5189  int case_ignore = 0;
5190  int result = 0;
5191  int pos;
5192 
5193  // Chek for error args
5194  if (IS_ERROR( data1 ))
5195  {
5196  RETURN( USE(data1) );
5197  }
5198  if (IS_ERROR( data2 ))
5199  {
5200  RETURN( USE(data2) );
5201  }
5202 
5203  // Check for lists - easy way to return FALSE
5204  if (IS_LIST( data1 ) || IS_LIST( data2 ))
5205  {
5206  RETURN( USE( false_true[0] ) );
5207  }
5208 
5209  // Get words from atoms
5210  data1 = atom_to_word( data1 );
5211  if (IS_ERROR( data1 ))
5212  {
5213  RETURN( data1 );
5214  }
5215  data2 = atom_to_word( data2 );
5216  if (IS_ERROR( data2 ))
5217  {
5218  DEUSE( data1 );
5219  RETURN( data2 );
5220  }
5221 
5222  if (!atom_to_boolean( cip, &case_ignore ))
5223  {
5224  case_ignore = 1;
5225  }
5226 
5227  // Here is the comparison
5228  for (pos = 0; pos + LENGTH( data1 ) <= LENGTH( data2 ); ++pos)
5229  {
5230  if (!word_compare( case_ignore, STRING( data2 ) + pos, LENGTH( data1 ),
5231  STRING( data1 ), LENGTH( data1 ) ))
5232  {
5233  result = 1;
5234  break;
5235  }
5236  }
5237 
5238  //clear and return
5239  DEUSE( data1 );
5240  DEUSE( data2 );
5241  RETURN( USE( false_true[result] ) );
5242 }
5243 
5244 
5245 //===================================================
5257 //===================================================
5258 
5259 atom_t RUNTIME rt_substring( atom_t cip, atom_t data2, atom_t data1 )
5260 {
5261  int case_ignore = 0;
5262  int result = 0;
5263  int pos;
5264 
5265  // Chek for error args
5266  if (IS_ERROR( data1 ))
5267  {
5268  RETURN( USE(data1) );
5269  }
5270  if (IS_ERROR( data2 ))
5271  {
5272  RETURN( USE(data2) );
5273  }
5274 
5275  // Get words from atoms
5276  data1 = atom_to_word( data1 );
5277  if (IS_ERROR( data1 ))
5278  {
5279  RETURN( data1 );
5280  }
5281  data2 = atom_to_word( data2 );
5282  if (IS_ERROR( data2 ))
5283  {
5284  DEUSE( data1 );
5285  RETURN( data2 );
5286  }
5287 
5288  if (!atom_to_boolean( cip, &case_ignore ))
5289  {
5290  case_ignore = 1;
5291  }
5292 
5293  // Here is the search
5294  for (pos = 0; pos + LENGTH( data1 ) <= LENGTH( data2 ); ++pos)
5295  {
5296  if (!word_compare( case_ignore, STRING( data2 ) + pos, LENGTH( data1 ),
5297  STRING( data1 ), LENGTH( data1 ) ))
5298  {
5299  result = pos+1;
5300  break;
5301  }
5302  }
5303 
5304  //clear and return
5305  DEUSE( data1 );
5306  DEUSE( data2 );
5307  RETURN( new_integer(result) );
5308 }
5309 
5310 
5311 //===================================================
5320 //===================================================
5321 
5322 atom_t RUNTIME rt_combine( atom_t data2, atom_t data1 )
5323 {
5324  atom_t res;
5325 
5326  if (IS_ERROR( data1 )) RETURN( USE(data1) );
5327  if (IS_ERROR( data2 )) RETURN( USE(data2) );
5328 
5329  if (IS_LIST( data2 ))
5330  {
5331  RETURN( new_list( USE( data1 ), USE( data2 ) ) );
5332  }
5333  data1 = atom_to_word( data1 );
5334  if (IS_ERROR( data1 ))
5335  {
5336  RETURN( data1 );
5337  }
5338  data2 = atom_to_word( data2 );
5339  if (IS_ERROR( data2 ))
5340  {
5341  DEUSE( data1 );
5342  RETURN( data2 );
5343  }
5344 
5345  // Copy the data
5346  res = create_word( LENGTH( data1 ) + LENGTH( data2 ) );
5347  STRNCPY( STRING( res ), STRING( data1 ), LENGTH( data1 ) );
5348  STRNCPY( STRING( res ) + LENGTH( data1 ), STRING( data2 ), LENGTH( data2 ) );
5349  *(STRING( res ) + LENGTH( data1 ) + LENGTH( data2 )) = NULL_CHAR;
5350 
5351  DEUSE( data1 );
5352  DEUSE( data2 );
5353  RETURN( res );
5354 }
5355 
5356 
5357 //===================================================
5365 //===================================================
5366 
5368 {
5369  atom_t res;
5370  if (IS_ERROR( data )) RETURN( USE(data) );
5371  if (IS_LIST( data )) RETURN( USE( data ) );
5372 
5373  data = atom_to_word( data );
5374  if (IS_ERROR( data )) RETURN( data );
5375 
5376  res = create_word( LENGTH( data ) + 1 );
5377  STRING( res )[0] = '\"';
5378  STRNCPY( STRING( res ) + 1, STRING( data ), LENGTH( data ) );
5379  *(STRING( res ) + LENGTH( data ) + 1) = NULL_CHAR;
5380  DEUSE( data );
5381  RETURN( res );
5382 }
5383 
5384 
5385 //===================================================
5400 //===================================================
5401 
5402 atom_t RUNTIME rt_throw( int count, atom_t data1, atom_t data2 )
5403 {
5404  atom_t tag;
5405  atom_t value;
5406 
5407  if (count == 1)
5408  {
5409  tag = data1;
5410  value = unbound;
5411  }
5412  else
5413  {
5414  tag = data2;
5415  value = data1;
5416  }
5417 
5418  // THROW "TOPLEVEL
5419  if (same_words( tag, word_toplevel ))
5421 
5422  // THROW "SYSTEM
5423  if (same_words( tag, word_system ))
5425 
5426  // THROW "ERROR
5427  // THROW "ERROR <message>
5428  if (same_words( tag, word_error ))
5429  {
5430  if (count == 1)
5431  {
5433  }
5434  else
5435  {
5437  }
5438  }
5439 
5440  // THROW <tag>
5441  // THROW <tag> <value>
5442  atom_t list = new_list( USE( tag ), new_list( USE( value ), empty_list ) );
5443  atom_t result = new_error( count == 1 ? EXIT_BY_THROW_TAG : EXIT_BY_THROW_TAG_VALUE, list );
5444  DEUSE( list );
5445  RETURN( result );
5446 }
5447 
5448 
5449 
5450 //===================================================
5457 //===================================================
5458 
5459 atom_t RUNTIME rt_catch( atom_t commands, atom_t tag )
5460 {
5461  RETURN( unbound );
5462 }
5463 
5464 
5465 
5467 //===================================================
5484 //===================================================
5485 #define rt_catchchk __attribute__((used,noinline,regparm(0),stdcall)) rt_catchchk
5486 
5487 atom_t rt_catchchk( int status, atom_t tag, atom_t data )
5488 //atom_t rt_catchchk( atom_t tag, atom_t data )
5489 #undef rt_catchchk
5490 {
5491  //printf("---------------\n");
5492  //printf("inside rt_catchchk\n");
5493  //printf(" - data%d = ",IS_UNBOUND(data)); dumpln(data);
5494  //printf(" - tag = "); dumpln(tag);
5495  //printf(" - status = %d\n",status);
5496  //printf("---------------\n");
5497 
5498  atom_t result;
5499 
5500  catch_output_flag = status;
5501 
5502  if (!IS_ERROR( data ))
5503  {
5504  //catch_output_flag = 0;
5505  DEUSE( tag );
5506 
5507  return data;
5508  }
5509  //printf("CATCH TAG=");dumpln(tag);
5510  //printf("ERRDATA=");dumpln((ERRDATA(data)));
5511  //printf("THROW TAG=");dumpln(CAR(ERRDATA(data)));
5512 
5513  // process true errors
5514  if (ERRCODE( data ) < FIRST_EXIT_CODE || ERRCODE( data ) > LAST_EXIT_CODE)
5515  {
5516  if (!IS_ANY_WORD( tag ))
5517  {
5518  DEUSE( tag );
5519  return data;
5520  }
5521 
5522  if (!same_words( word_error, tag ))
5523  {
5524  DEUSE( tag );
5525  return data;
5526  }
5527 
5528  result = unbound;
5529  goto exit_catch;
5530  }
5531 
5532  // return throw-exception if tags are not (sub)words
5533  if (!IS_ANY_WORD( tag ) || !IS_ANY_WORD( CAR( ERRDATA( data ) ) ))
5534  {
5535  DEUSE( tag );
5536  return data;
5537  }
5538  // return throw-exception is tags are not equal
5539  if (!same_words( tag, CAR( ERRDATA( data ) ) ))
5540  {
5541  DEUSE( tag );
5542  return data;
5543  }
5544 
5545  // tags match or error captured
5546  result = USE( CAR( CDR( ERRDATA( data ) ) ) );
5547 
5548  exit_catch:
5549  //while (REF( data ) > 1) DEUSE( data ); //2009
5550  //DEUSE( last_error );
5551  last_error = data;
5552  //clear_all_errors();
5553  DEUSE( tag );
5554  //printf("result="); dumpln(result);
5555  //printf("last_error(%d)=",REF(last_error)); dumpln(last_error);
5556 
5557  catch_output_flag = 0; // forget any OUTPUT with error
5558  return result;
5559 }
5560 
5561 
5562 
5563 
5564 
5565 //===================================================
5573 //===================================================
5574 
5576 {
5577  if (IS_EMPTY( last_error ))
5578  RETURN( last_error );
5579 
5580 #ifdef SAFEMODE
5581  assert( IS_ERROR( last_error ) );
5582 #endif
5583 
5584  atom_t code;
5585  atom_t message;
5586  atom_t procedure;
5587  atom_t source;
5588 
5589  //printf("--LAST ERROR->"); dump_atom(last_error,1); printf("\n");
5590 
5591 
5592  // get error code
5593  code = new_integer( ERRCODE( last_error ) );
5594  //printf("--ERROR CODE-->"); dump_atom(code,1); printf("\n");
5595 
5596  // get error message
5598  message = USE( ERRDATA( last_error ) );
5599  else
5600  message = USE( error_texts[ERRCODE( last_error )] );
5601  //printf("--MESSAGE-->"); dump_atom(message,1); printf("\n");
5602 
5603  // get error procedure/source
5604  source = empty_list;
5605  procedure = empty_list;
5606  atom_t p;
5607  for (p = ERRPOS( last_error ); IS_NOT_EMPTY( p ); p = CDR( p ))
5608  if (IS_LIST( CAR( p ) ))
5609  {
5610  //printf("---"); dump_atom(p,1); printf("\n");
5611  //printf(">>>"); dumpln(CAR(p));
5612  if (!IS_EXPRESSION( CAR( p ) )) continue;
5613  //printf("???"); dumpln(CAR(CAR(p)));
5614  atom_t var = find_var( CAR( CAR( p ) ), globals );
5615  if (var && IS_PRIMITIVE( var )) continue;
5616  //printf("!!!\n");
5617  source = CAR( p );
5618  procedure = CAR( source );
5619  }
5620  //printf("--AFTER FOR-->!\n");
5621 
5622  atom_t result;
5623  result = new_list( USE( source ), empty_list );
5624  result = new_list( USE( procedure ), result );
5625  result = new_list( message, result );
5626  result = new_list( code, result );
5627 
5628  //REF(last_error) = 1;
5629  //DEUSE( last_error );
5631  //printf("--BEFORE CLEAR-->!\n");
5632  //clear_all_errors(); //2011.11.30 removed, because causes bug 3445230. now all test cases work fine
5633  //printf("--AFTER CLEAR-->!\n");
5634 
5635  RETURN( result );
5636 }
5637 
5638 
5639 
5640 //===================================================
5645 //===================================================
5646 
5648 {
5649  RETURN( unbound );
5650 }
5651 
5652 
5653 
5654 //===================================================
5667 //===================================================
5668 
5669 atom_t RUNTIME rt_goto( int static_link, atom_t parent, atom_t data, atom_t source )
5670 {
5671  if (IS_ERROR( data )) return ( USE( data ));
5672  if (!IS_ANY_WORD( data )) return ( new_error( ERROR_NOT_A_WORD, source ));
5673 
5674  atom_t var = find_local_var( data, parent );
5675  if (!var || !IS_TAG( var )) return ( new_error( ERROR_NOT_A_TAG, source ));
5677  //printf("jumpto=%x\n",(int)INTEGER(VALUE(var)));
5678  RETURN( USE( VALUE( var ) ) );
5679 }
5680 
5681 
5682 
5683 
5684 //===================================================
5693 //===================================================
5694 
5695 atom_t RUNTIME rt_iftrue( atom_t commands )
5696 {
5697  RETURN( unbound );
5698 }
5699 
5700 
5701 
5703 //===================================================
5712 //===================================================
5713 
5714 atom_t RUNTIME rt_iffalse( atom_t commands )
5715 {
5716  RETURN( unbound );
5717 }
5718 
5719 
5720 
5721 //===================================================
5732 //===================================================
5733 
5734 atom_t RUNTIME rt_test( atom_t condition, int frame )
5735 {
5736  int* test_ptr;
5737 
5738  test_ptr = (int*) (frame + BASE_OFFSET_TEST);
5739  GET_BOOLEAN( condition, *test_ptr );
5740 
5742 }
5743 
5744 
5745 
5746 
5747 //===================================================
5754 //===================================================
5755 
5757 {
5758  data = atom_to_word( data );
5759  if (IS_ERROR( data ))
5760  {
5761  RETURN( USE(data) );
5762  }
5764  if (LENGTH( data ) != 1)
5765  {
5767  }
5768 
5769  char_t ch = *STRING( data );
5770  DEUSE( data );
5771  RETURN( USE( false_true[ch != DEBAR( ch )] ) );
5772 }
5773 
5774 
5775 
5776 
5777 //===================================================
5788 //===================================================
5789 
5790 atom_t RUNTIME rt_text( int static_link, atom_t parent, atom_t data )
5791 {
5792  atom_t word = atom_to_word( data );
5793  if (IS_ERROR( word )) RETURN( USE(word) );
5794 
5795  //printf("looking for "); dump(word); printf(" in "); dumpln(NAME(parent));
5796  atom_t var = find_var( word, parent );
5797  DEUSE( word );
5798 
5799  //test for invalid variable types
5800  if (IS_PRIMITIVE( var ) || (!IS_FUNCTION( var ) && !IS_COMMAND( var )))
5802 
5803  atom_t result = empty_list;
5804  atom_t reslast = empty_list;
5805 
5806  atom_t element = empty_list;
5807  atom_t elemlast = empty_list;
5808 
5809  atom_t x;
5810  int n;
5811 
5812  // prepare list of right inputs
5813  // because of their reverse order, we can
5814  // construct the list without append()
5815  for (x = LOCALS( var ), n = 0; IS_NOT_EMPTY( x ); x = CDR( x ))
5816  if (IS_NORMAL( CAR( x ) ) && IS_VARIABLE( CAR( x ) ) && OFFSET( CAR( x ) ) > 0)
5817  {
5818  n++;
5819  if (n > RARGS( var ))
5820  element = new_list( USE( NAME( CAR( x ) ) ), element ); // left inputs
5821  else
5822  result = new_list( USE( NAME( CAR( x ) ) ), result ); // right inputs
5823  }
5824 
5825  // if there were left inputs then put them as
5826  // a sublist in front of right inputs
5827  if (IS_NOT_EMPTY( element ))
5828  {
5829  result = new_list( element, result );
5830  element = empty_list;
5831  }
5832 
5833  // pack all inputs as the first element of the result
5834  result = new_list( result, empty_list );
5835  reslast = result;
5836 
5837  // group elements into lines
5838  for (x = BODY( var ); IS_NOT_EMPTY( x ); x = CDR( x ))
5839  {
5840  if (IS_NOT_EMPTY( element ) && GET_FLAGS( x, FLAG_NEWLINE ))
5841  {
5842  append( element, &result, &reslast );
5843  element = empty_list;
5844  elemlast = empty_list;
5845  }
5846  append( USE( CAR( x ) ), &element, &elemlast );
5847  }
5848 
5849  // process any leftovers
5850  if (IS_NOT_EMPTY( element ))
5851  {
5852  append( element, &result, &reslast );
5853  }
5854 
5855  RETURN( result );
5856 }
5857 
5858 
5859 
5860 
5861 //===================================================
5873 //===================================================
5874 
5875 atom_t RUNTIME rt_fulltext( int static_link, atom_t parent, atom_t data )
5876 {
5877  atom_t word = atom_to_word( data );
5878  if (IS_ERROR( word )) RETURN( USE(word) );
5879 
5880  //printf("looking for "); dump(word); printf(" in "); dumpln(NAME(parent));
5881  atom_t var = find_var( word, parent );
5882  DEUSE( word );
5883 
5884  //test for invalid variable types
5885  if (IS_PRIMITIVE( var ) || (!IS_FUNCTION( var ) && !IS_COMMAND( var )))
5887 
5888  atom_t result;
5889  if (IS_ANY_WORD( SOURCE( var ) ))
5890  result = USE( FULLSOURCE( var ) );
5891  else
5892  result = rt_text( static_link, parent, data );
5893 
5894  RETURN( result );
5895 }
5896 
5897 
5898 
5899 
5900 //===================================================
5920 //===================================================
5921 
5922 atom_t RUNTIME rt_run( int static_link, atom_t parent, atom_t data, int mode )
5923 {
5924  //printf("-----------ENTER rt_run()---------------\n");
5925  //printf("compiling "); dump_atom(data,1); printf("\n");
5926  //if( mode==COMPILE_AS_PROC ) printf("--->procedure<---\n");
5927  //if( mode==COMPILE_AS_FUNC ) printf("--->function<---\n");
5928  //if( mode==COMPILE_AS_UNKNOWN ) printf("--->both proc&func<---\n");
5929  //printf("--->in parent= "); dump_atom(parent,1); printf("\n");
5930 
5931  if (IS_ERROR( data )) RETURN( USE(data) );
5932 
5933  // create temporary local var where to compile the code
5934  atom_t func = new_var( word_to, parent, 0 );
5935  need_descr2( func );
5936 
5937  SOURCE( func ) = USE( data );
5938 
5939  compiling_code = 1;
5940  atom_t x = compile_function( func, mode, COMPILE_AS_NON_MACRO );
5941  compiling_code = 0;
5942  if (IS_ERROR( x ))
5943  {
5944  DEUSE( func );
5945  RETURN( x );
5946  }
5947 
5948  //printf("compiled tree="); dump_atom(TREE(func),1); printf("\n");
5949  //printf("-----------EXIT rt_run()---------------\n");
5950  //printf("result="); dumpln(func);
5951  //printf("---------------------------------------\n");
5952  //printf("!!!locals ="); dump_atom(LOCALS(func),1); printf("\n");
5953  //printf("!!!to transfer to parent="); dump_atom(NAME(PARENT(func)),1); printf("\n");
5954  //printf("---------------------------------------\n");
5955 
5956  // wrong place:: transfer all local vars from here to the parent of run
5957  // it is wrong, because transfer should be done after the code is
5958  // executed. currently the code is only compiled
5959  //atom_t a;
5960  //for( a=LOCALS(func); IS_NOT_EMPTY(a); a=CDR(a) )
5961  // {
5962  // //printf(" "); dump_atom(NAME(CAR(a)),1);
5963  //
5964  // }
5965  //printf("\n");
5966  RETURN( func );
5967 }
5968 
5969 
5970 
5971 
5972 //===================================================
5992 //===================================================
5993 
5994 atom_t RUNTIME rt_runmacro( int static_link, atom_t parent, atom_t data, int mode )
5995 {
5996  //printf("-----------ENTER rt_run()---------------\n");
5997  //printf("compiling "); dump_atom(data,1); printf("\n");
5998  //if( mode==COMPILE_AS_PROC ) printf("--->procedure<---\n");
5999  //if( mode==COMPILE_AS_FUNC ) printf("--->function<---\n");
6000  //if( mode==COMPILE_AS_UNKNOWN ) printf("--->both proc&func<---\n");
6001  //printf("--->in parent= "); dump_atom(parent,1); printf("\n");
6002 
6003 
6004  if (IS_ERROR( data )) RETURN( USE(data) );
6005 
6006  // create temporary local var where to compile the code
6007  atom_t func = new_var( word_to, parent, 0 );
6008  need_descr2( func );
6009 
6010  SOURCE( func ) = USE( data );
6011 
6012  compiling_code = 1;
6013  atom_t x = compile_function( func, mode, COMPILE_AS_MACRO );
6014  compiling_code = 0;
6015  if (IS_ERROR( x ))
6016  {
6017  DEUSE( func );
6018  RETURN( x );
6019  }
6020 
6021  RETURN( func );
6022 }
6023 
6024 
6025 
6026 
6027 //===================================================
6037 //===================================================
6038 
6039 atom_t RUNTIME rt_runresult( int static_link, atom_t parent, atom_t data )
6040 {
6041  atom_t res = rt_run( static_link, parent, data, COMPILE_AS_UNKNOWN );
6042  RETURN( res );
6043 }
6044 
6045 
6047 
6048 //===================================================
6058 //===================================================
6059 #define rt_runresult_fix __attribute__((used,noinline,regparm(0),stdcall)) rt_runresult_fix
6060 
6062 #undef rt_runresult_fix
6063 {
6064  if (IS_ERROR( data )) RETURN( USE(data) );
6065  if (IS_UNBOUND( data )) RETURN( empty_list );
6067 }
6069 
6070 
6071 
6072 //===================================================
6081 //===================================================
6082 
6083 atom_t RUNTIME rt_define( int static_link, atom_t parent, atom_t value, atom_t name )
6084 {
6085  if (IS_ERROR( value )) RETURN( USE(value) );
6086  if (IS_ERROR( name )) RETURN( USE(name) );
6087 
6088  atom_t word = atom_to_word( name );
6089  if (IS_ERROR( word )) RETURN( word );
6091  if (!IS_LIST( value ))
6092  {
6093  DEUSE( word );
6094  RETURN( new_error( ERROR_NOT_A_LIST, value ) );
6095  }
6096 
6097  // create function (similarily to define_user_function)
6098 #ifdef DEBUG_TO_END
6099  printf( "<TO-END-RUNTIME> DEFINING=" );
6100  dumpln( name );
6101 #endif
6102 
6103  // create the function
6104  atom_t function = new_var( word_to, parent, 1 ); //DEUSE(to);
6105  need_descr2( function );
6106  SET_FLAGS( function, FLAG_FUNCTION );
6107  LARGS( function ) = 0;
6108  RARGS( function ) = 0;
6109 
6110  // get lists of left and right inputs
6111  atom_t lefts = empty_list; // left inputs
6112  atom_t rights = empty_list; // right inputs
6113 
6114  if (IS_NOT_EMPTY( value ))
6115  { // there is at least one element
6116  // is it list?
6117  if (IS_LIST( CAR( value ) )) rights = CAR( value );
6118 
6119  // now test for left parameters
6120  if (IS_NOT_EMPTY( rights ) && IS_LIST( CAR( rights ) ))
6121  {
6122  lefts = CAR( rights );
6123  rights = CDR( rights );
6124  }
6125  }
6126 
6127 #ifdef DEBUG_TO_END
6128  printf( "<TO-END-RUNTIME> LEFT PARAMS=" );
6129  dumpln( lefts );
6130  printf( "<TO-END-RUNTIME> RIGHT PARAMS=" );
6131  dumpln( rights );
6132 #endif
6133 
6134  // process left inputs
6135  while (IS_NOT_EMPTY( lefts ))
6136  {
6137  if (!IS_ANY_WORD( CAR( lefts ) ))
6138  {
6139  DEUSE( word );
6140  LOCALS( parent ) = behead( LOCALS( parent ) ); // this DEUSEs function
6141  return new_error( ERROR_NOT_A_WORD, lefts );
6142  }
6143 
6144  atom_t var = new_local_var( CAR( lefts ), function, 0 );
6145  if (IS_ERROR( var ))
6146  {
6147  DEUSE( word );
6148  LOCALS( parent ) = behead( LOCALS( parent ) ); // this DEUSEs function
6149  return var;
6150  }
6151 
6152  SET_FLAGS( var, FLAG_VARIABLE );
6153  LARGS( function )++;
6154 #ifdef SAFE_MODE
6155  assert( LARGS( function ) < 255 );
6156 #endif
6157  lefts = CDR( lefts );
6158  }
6159 
6160  // process right inputs
6161  while (IS_NOT_EMPTY( rights ))
6162  {
6163  if (!IS_ANY_WORD( CAR( rights ) ))
6164  {
6165  DEUSE( word );
6166  LOCALS( parent ) = behead( LOCALS( parent ) ); // this DEUSEs function
6167  return new_error( ERROR_NOT_A_WORD, rights );
6168  }
6169 
6170  atom_t var = new_local_var( CAR( rights ), function, 0 );
6171  if (IS_ERROR( var ))
6172  {
6173  DEUSE( word );
6174  LOCALS( parent ) = behead( LOCALS( parent ) ); // this DEUSEs function
6175  return var;
6176  }
6177 
6178  SET_FLAGS( var, FLAG_VARIABLE );
6179  RARGS( function )++;
6180 #ifdef SAFE_MODE
6181  assert( RARGS( function ) < 255 );
6182 #endif
6183  rights = CDR( rights );
6184  }
6185 
6186 #ifdef DEBUG_TO_END
6187  printf( "<TO-END-RUNTIME> FUNC DEF=" );
6188  dumpln( function );
6189 #endif
6190 
6191 
6192  // set offset of parameters
6193  int offset = BASE_OFFSET_PARAMS; // this is the start offset
6194  atom_t x;
6195  for (x = LOCALS( function ); IS_NOT_EMPTY( x ); x = CDR( x ))
6196  {
6197  //printf("set offset of "); dump(NAME(CAR(x))); printf(" to be %d\n",offset);
6198  OFFSET( CAR( x ) ) = offset;
6199  offset += sizeof ( atom_t);
6200  }
6201 
6202  // the CDR(value) is the body of the function, but it is
6203  // cut into sublists -- each line is a single list. So
6204  // all these list should be combined into one, which will
6205  // become the body of the function
6206  atom_t body = empty_list;
6207  atom_t body_end = empty_list;
6208  atom_t a;
6209  atom_t b;
6210  for (a = CDR( value ); IS_NOT_EMPTY( a ); a = CDR( a ))
6211  {
6212  b = CAR( a );
6213  if (IS_NOT_EMPTY( b ))
6214  { // the first element should have FLAG_NEWLINE set
6215  append( USE( CAR( b ) ), &body, &body_end );
6216  SET_FLAGS( body, FLAG_NEWLINE );
6217  }
6218  for (b = CDR( b ); IS_NOT_EMPTY( b ); b = CDR( b ))
6219  append( USE( CAR( b ) ), &body, &body_end );
6220  }
6221 
6222 #ifdef DEBUG_TO_END
6223  printf( "<TO-END-RUNTIME> FUNC BODY=" );
6224  dumpln( body );
6225 #endif
6226 
6227 
6228 
6229  // check whether the function is already defined
6230  atom_t var = find_runtime_var( word, static_link );
6231  if (var)
6232  {
6233  if (LARGS( var ) != LARGS( function ) || RARGS( var ) != RARGS( function ))
6234  {
6235  LOCALS( parent ) = behead( LOCALS( parent ) ); // this DEUSEs function
6237  return result;
6238  }
6239 
6240  // forget data of the old function and
6241  // reuse data of the new function
6242  DEUSE( FULLSOURCE( var ) );
6243  DEUSE( SOURCE( var ) );
6244  DEUSE( LOCALS( var ) );
6245  DEUSE( BODY( var ) );
6246  DEUSE( TREE( var ) );
6247  DEUSE( BINARY( var ) );
6248 
6249  BODY( var ) = empty_list;
6250  TREE( var ) = empty_list;
6251  BINARY( var ) = empty_list;
6252 
6253  SOURCE( var ) = body;
6254  LOCALS( var ) = USE( LOCALS( function ) );
6255 
6256  LOCALS( parent ) = behead( LOCALS( parent ) );
6257  //DEUSE(function);
6258  function = var;
6259  }
6260  else
6261  {
6262  DEUSE( NAME( function ) );
6263  NAME( function ) = USE( word );
6264  BODY( function ) = empty_list;
6265  }
6266 
6267  //LEVEL( function ) = level;
6268  ADDRESS( function ) = 0;
6269  PRIORITY( function ) = PRIORITY_FUN;
6270 
6271  SOURCE( function ) = body;
6272  FULLSOURCE( function ) = unbound;
6273 
6274  //DEUSE( input );
6275 #ifdef DEBUG_TO_END
6276  printf( "<TO-END> DEFINED FUNCTION " );
6277  dumpln( NAME( function ) );
6278  printf( "<TO-END> SOURCE " );
6279  dumpln( SOURCE( function ) );
6280  printf( "<TO-END> BODY " );
6281  dumpln( BODY( function ) );
6282  printf( "<TO-END> TREE " );
6283  dumpln( TREE( function ) );
6284 #endif
6285 
6286  DEUSE( word );
6287 
6289  if (IS_ERROR( y )) return y;
6290 
6291  return unbound;
6292 }
6293 
6294 
6295 //===================================================
6306 //===================================================
6307 
6308 atom_t RUNTIME rt_for( atom_t body, atom_t limits, atom_t var )
6309 {
6310  RETURN( unbound );
6311 }
6312 
6313 
6314 
6315 //===================================================
6323 //===================================================
6324 
6326 {
6327  void* handle;
6328 
6329  if (IS_ERROR( data ))
6330  {
6331  RETURN( USE(data) );
6332  }
6333 
6334  if (!IS_ANY_WORD( data ))
6335  {
6336  RETURN( new_error( ERROR_NOT_A_WORD, data ) );
6337  }
6338 
6339  // convert char_t* into char*
6340  int len = LENGTH( data );
6341  chars_t ptr = STRING( data );
6342  char filename[len + 1+3+1+2];
6343  int i=0;
6344  //#ifndef WINDOWS
6345  //filename[i++] = 'l';
6346  //filename[i++] = 'i';
6347  //filename[i++] = 'b';
6348  //len += 3;
6349  //#endif
6350 
6351  for (; i < len; i++) filename[i] = *(ptr++);
6352  filename[len] = '\0';
6353  //#ifndef WINDOWS
6354  //filename[len++] = '.';
6355  //filename[len++] = 's';
6356  //filename[len++] = 'o';
6357  //filename[len] = '\0';
6358  //#endif
6359 
6360  //dumpln(data);
6361  //fprintf(stderr, "loading library %s\n\n\n",filename);
6362  handle = dlopen( filename, RTLD_LAZY );
6363  //if (!handle) fputs(dlerror(), stderr);
6364  //fprintf(stderr, "\nloaded result=%d.\n",(int)handle);
6365  if( !handle )
6366  {
6367  // searching failed, try again looking in subfolder
6368  // lib of the folder where the compiler is
6369  char buf[PATH_MAX+1];
6371  char* path = dirname(buf);
6372  int pathlen = strlen(path);
6373  strncpy(buf,path,pathlen);
6374 
6375  int filelen = strlen(filename);
6376  if( pathlen+filelen+6 > PATH_MAX ) filelen=0;
6377 #ifdef WINDOWS
6378  strncpy(buf+pathlen,"\\lib\\",5);
6379 #else
6380  strncpy(buf+pathlen,"/lib/",5);
6381 #endif
6382  strncpy(buf+5+pathlen,filename,filelen);
6383  buf[pathlen+5+filelen] = '\0';
6384 
6385  //printf("failed %s, try '%s' while compiler is %s\n",filename,buf,option_compiler_filename);
6386  handle = dlopen( buf, RTLD_LAZY );
6387  }
6388 
6389  return new_integer( (int) handle );
6390 }
6391 
6392 
6393 //===================================================
6400 //===================================================
6401 
6403 {
6404  int64_t x;
6405 
6406  GET_INT( data, x );
6407 
6408  dlclose( (void*) (int) x );
6410  return unbound;
6411 }
6412 
6413 
6414 //===================================================
6426 //===================================================
6427 
6428 atom_t RUNTIME rt_blocksize( int static_link, atom_t parent, atom_t prototype )
6429 {
6430  CHECK_PARAM( prototype );
6431 
6432  if( IS_LIST( prototype ) )
6433  {
6434  RETURN( traverse_pack( static_link, parent, prototype, empty_list, 0, MEM_STRUCT_SIZE ) );
6435  }
6436  else if( IS_MEM(prototype) && IS_INTEGER(ATOMS(prototype)) )
6437  {
6438  RETURN( USE( ATOMS(prototype) ) );
6439  }
6440  else
6441  {
6442  RETURN( new_error(ERROR_NOT_BLOCK_OR_DEF,prototype) );
6443  }
6444 }
6445 
6446 
6447 
6448 //===================================================
6459 //===================================================
6460 atom_t RUNTIME rt_listtoblock( int static_link, atom_t parent, atom_t prototype, atom_t data )
6461 {
6462  atom_t size = rt_blocksize( static_link, parent, prototype );
6463  if( IS_ERROR(size) )
6464  {
6465  RETURN( size );
6466  }
6468  atom_t memory = new_mem( INTEGER(size) );
6469  ATOMS(memory) = size;
6470 
6471  void* ptr = MEMORY( memory );
6472 
6473  atom_t res = traverse_pack( static_link, parent, prototype, data, ptr, MEM_STRUCT_PACK );
6474  if( IS_ERROR(res) )
6475  {
6476  DEUSE( memory );
6477  RETURN( res );
6478  }
6479 
6480  RETURN( memory );
6481 }
6482 
6483 
6484 
6485 
6486 //===================================================
6498 //===================================================
6499 atom_t RUNTIME rt_blocktolist( int static_link, atom_t parent, atom_t prototype, atom_t data )
6500 {
6501  void* ptr;
6502  if( data==empty_list )
6503  {
6504 
6505  RETURN( new_error( ERROR_NOT_A_MEM, data ) );
6506  }
6507 
6508  if( IS_MEM(data) )
6509  ptr = MEMORY( data );
6510  else
6511  {
6512  int64_t addr;
6513  GET_INT( data, addr );
6514  ptr = (void*)(int)addr;
6515  }
6516 
6517  atom_t res = traverse_pack( static_link, parent, prototype, empty_list, ptr, MEM_STRUCT_UNPACK );
6518  return res;
6519 }
6520 
6521 
6522 
6523 //===================================================
6531 //===================================================
6532 
6534 {
6535  RETURN( new_integer((int)data) );
6536 }
6537 
6538 
6539 
6541 //===================================================
6554 //===================================================
6555 atom_t RUNTIME rt_listintoblock( int static_link, atom_t parent, atom_t prototype, atom_t dest, atom_t data )
6556 {
6557  void* ptr;
6558  if( IS_MEM(dest) )
6559  ptr = MEMORY( dest );
6560  else
6561  {
6562  int64_t addr;
6563  GET_INT( dest, addr );
6564  ptr = (void*)(int)addr;
6565  }
6566 
6567  atom_t res = traverse_pack( static_link, parent, prototype, data, ptr, MEM_STRUCT_PACK );
6568  RETURN( res );
6569 }
6570 
6571 
6572 
6573 //===================================================
6584 //===================================================
6585 atom_t RUNTIME rt_funcaddr( int static_link, atom_t parent, atom_t data )
6586 {
6587  if (IS_ERROR( data )) RETURN( USE(data) );
6588 
6589  atom_t word = atom_to_word( data );
6590  if (IS_ERROR( word )) RETURN( word );
6591 
6592  atom_t var = find_runtime_var( word, static_link );
6593  DEUSE( word );
6594 
6595  // not found
6596  if (!var)
6597  RETURN( new_error( ERROR_UNKNOWN_VAR, data ) );
6598 
6599  // not a variable (i.e. it is a function or a procedure)
6600  if (IS_VARIABLE( var ) || IS_PRIMITIVE( var ))
6602 
6603  RETURN( new_integer(ADDRESS(var)) );
6604 }
6605 
6606 
6607 
6608 
6609 //===================================================
6622 //===================================================
6623 atom_t RUNTIME rt_external (int static_link, atom_t parent, atom_t handle, atom_t prototype, atom_t name)
6624 {
6625  //printf(" handle = "); dumpln(handle);
6626  //printf(" prototype = "); dumpln(prototype);
6627  //printf(" name = "); dumpln(name);
6629 //printf("enter p="); dumpln(ppp);
6631  if( IS_ERROR(handle) ) RETURN( USE(handle) );
6632  if( IS_ERROR(prototype) ) RETURN( USE(prototype) );
6633  if( IS_ERROR(name) ) RETURN( USE(name) );
6634 
6635  int hnd = 0;
6636  if( !atom_to_integer(handle,&hnd) )
6638 
6639  // check whether the Logo function exists
6640  atom_t word = atom_to_word( name );
6641  if( IS_ERROR(word) ) RETURN( word );
6642  atom_t var = find_runtime_var( word, static_link );
6643  DEUSE( word );
6644  if( !var ) RETURN( new_error( ERROR_NOT_A_USER_FUNCTION, name ) );
6645  if( !IS_NORMAL(var) ) RETURN( new_error( ERROR_NOT_A_USER_FUNCTION, name ) );
6646  if( !IS_FUNCTION(var) && !IS_COMMAND(var) ) RETURN( new_error( ERROR_NOT_A_USER_FUNCTION, name ) );
6647 
6648  // check prototype
6649  if( !IS_LIST(prototype) ) RETURN( new_error( ERROR_NOT_A_LIST, prototype ) );
6650  if( list_length(prototype) < 2 ) RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );
6651 
6652  // process return type
6653  atom_t type = CAR( prototype );
6654  prototype = CDR( prototype );
6655 
6656  int c_type = get_c_type( static_link, parent, type );
6657  int class = c_types[c_type].class;
6658 
6659  // return type cannot be structure or unknown. Structures are usually
6660  // returned as pointer to structures.
6661  if( class==C_TYPE_STRUCT || class==C_TYPE_UNKNOWN )
6662  RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );
6663 
6664  VARTYPE( var ) = VAR_TYPE_EXTERNAL+c_type;
6665 
6666  // if the return type is void, then we have external
6667  // command, otherwise we have external function
6670 
6671  // get external name
6672  atom_t external_name = CAR( prototype );
6673  prototype = CDR( prototype );
6674  if( !IS_ANY_WORD(external_name) )
6675  RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );
6676  //printf("external name = "); dumpln(external_name);
6677 
6678  // check the correct order of parameters
6679  if( list_length(prototype) != RARGS(var) )
6680  RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );
6681 
6682  // now process parameters one-by-one
6683  atom_t params;
6684  int offset = BASE_OFFSET_PARAMS+(RARGS(var)-1)*sizeof(atom_t);
6685  for( ; IS_NOT_EMPTY(prototype); prototype=CDR(prototype) )
6686  {
6687  // get one type from the prototype
6688  type = CAR( prototype );
6689  c_type = get_c_type( static_link, parent, type );
6690  class = c_types[c_type].class;
6691 
6692  if( class==C_TYPE_STRUCT || class==C_TYPE_UNKNOWN )
6693  RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );
6694 
6695  // now find parameter with given offset
6696  for( params=LOCALS(var); IS_NOT_EMPTY(params); params=CDR(params))
6697  {
6698  atom_t param = CAR( params );
6699  if( !IS_VARIABLE(param) ) continue; // functions/commands not allowerd
6700  if( !IS_NORMAL(param) ) continue; // tags/runtimes not allowed
6701  if( OFFSET(param)==offset )
6702  {
6703  VARTYPE( param ) = VAR_TYPE_EXTERNAL+c_type;
6704  //printf(" :::param "); dump(NAME(param)); printf(" is class=%d name=%S\n", c_type, c_types[c_type].name);
6705  break;
6706  }
6707  }
6708 
6709  offset -= sizeof( atom_t );
6710  }
6711 
6712 #ifdef SAFE_MODE
6713  for( params=LOCALS(var); IS_NOT_EMPTY(params); params=CDR(params))
6714  assert( IS_EXTERNAL(CAR(params)) );
6715 #endif
6716 
6717  //printf("search function "); dump(external_name); printf(" in handle "); dumpln(handle);
6718 
6719  // convert char_t* into char*
6720  int len = LENGTH( external_name );
6721  chars_t ptr = STRING( external_name );
6722  char func_name[len + 1];
6723  int i;
6724  for (i = 0; i < len; i++) func_name[i] = *(ptr++);
6725  func_name[len] = '\0';
6726 
6727  void* address = dlsym( (void*)hnd, func_name );
6728 
6729  if( !address )
6730  RETURN( new_error( ERROR_NOT_A_FUNCTION, external_name ) );
6731 
6732  //printf("external address=%x\n",(int)address);
6733 
6734  ADDRESS( var ) = (int)address;
6736 //printf("exit p="); dumpln(ppp);
6737  RETURN( unbound );
6738 }
6739 
6740 
6741 
6742 
6743 //===================================================
6755 //===================================================
6756 atom_t RUNTIME rt_internal (int static_link, atom_t parent, atom_t prototype, atom_t name)
6757 {
6758  //printf(" prototype = "); dumpln(prototype);
6759  //printf(" name = "); dumpln(name);
6760 
6761  if( IS_ERROR(prototype) ) RETURN( USE(prototype) );
6762  if( IS_ERROR(name) ) RETURN( USE(name) );
6764  // check whether the Logo function exists
6765  atom_t word = atom_to_word( name );
6766  if( IS_ERROR(word) ) RETURN( word );
6767  atom_t var = find_runtime_var( word, static_link );
6768  DEUSE( word );
6769  if( !var ) RETURN( new_error( ERROR_NOT_A_USER_FUNCTION, name ) );
6770  if( !IS_NORMAL(var) ) RETURN( new_error( ERROR_NOT_A_USER_FUNCTION, name ) );
6771  if( !IS_FUNCTION(var) && !IS_COMMAND(var) ) RETURN( new_error( ERROR_NOT_A_USER_FUNCTION, name ) );
6772 
6773  // check prototype
6774  if( !IS_LIST(prototype) ) RETURN( new_error( ERROR_NOT_A_LIST, prototype ) );
6775  if( list_length(prototype) < 1 ) RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );
6776 
6777  // process return type
6778  atom_t type = CAR( prototype );
6779  prototype = CDR( prototype );
6780 
6781  int c_type = get_c_type( static_link, parent, type );
6782  int class = c_types[c_type].class;
6783 
6784  // return type cannot be structure or unknown. Structures are usually
6785  // returned as pointer to structures.
6786  if( class==C_TYPE_STRUCT || class==C_TYPE_UNKNOWN )
6787  RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );
6788  VARTYPE( var ) = VAR_TYPE_INTERNAL+c_type;
6789 
6790  // if the return type is void, then we have internal
6791  // command, otherwise we have internal function
6794 
6795  // check the correct order of parameters
6796  if( list_length(prototype) != RARGS(var) )
6797  RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );
6798 
6799  // now process parameters one-by-one
6800  atom_t params;
6801  int offset = BASE_OFFSET_PARAMS+(RARGS(var)-1)*sizeof(atom_t);
6802  for( ; IS_NOT_EMPTY(prototype); prototype=CDR(prototype) )
6803  {
6804  // get one type from the prototype
6805  type = CAR( prototype );
6806  c_type = get_c_type( static_link, parent, type );
6807  class = c_types[c_type].class;
6808 
6809  if( class==C_TYPE_STRUCT || class==C_TYPE_UNKNOWN )
6810  RETURN( new_error( ERROR_BAD_PROTOTYPE, prototype ) );
6811 
6812  // now find parameter with given offset
6813  for( params=LOCALS(var); IS_NOT_EMPTY(params); params=CDR(params))
6814  {
6815  atom_t param = CAR( params );
6816  if( !IS_VARIABLE(param) ) continue; // functions/commands not allowerd
6817  if( !IS_NORMAL(param) ) continue; // tags/runtimes not allowed
6818  if( OFFSET(param)==offset )
6819  {
6820  VARTYPE( param ) = VAR_TYPE_INTERNAL+c_type;
6821  //printf(" :::param "); dump(NAME(param)); printf(" is class=%d name=%S offset=%d\n", c_type, c_types[c_type].name,offset);
6822  break;
6823  }
6824  }
6825 
6826  offset -= sizeof( atom_t );
6827  }
6828 
6829 #ifdef SAFE_MODE
6830  for( params=LOCALS(var); IS_NOT_EMPTY(params); params=CDR(params))
6831  assert( IS_INTERNAL(CAR(params)) );
6832 #endif
6833 
6834  compile_internal_function( var, static_link );
6835  RETURN( unbound );
6836 }
6837 
6838 
6839 
6840 
6841 //===================================================
6854 //===================================================
6855 atom_t RUNTIME rt_stackframe (int static_link, atom_t parent, atom_t offset, atom_t frame)
6856 {
6857  int64_t ofs, frm;
6858  GET_INT( offset, ofs );
6859  GET_INT( frame, frm );
6860 
6861  int base = (frm<0)?BASE_OFFSET_DYNAMIC:BASE_OFFSET_STATIC;
6863  frm = abs(frm);
6864  for (; frm; frm--)
6865  static_link = *(int*) ((char*) static_link + base);
6866 
6867  RETURN( new_integer( *(int*) ((char*) static_link + (ofs*sizeof(atom_t))) ) );
6868 }
6869 
6870 
6871 
6872 //===================================================
6886 //===================================================
6887 atom_t RUNTIME rt_stackframeatom (int static_link, atom_t parent, atom_t offset, atom_t frame)
6888 {
6889  int64_t ofs, frm;
6890  GET_INT( offset, ofs );
6891  GET_INT( frame, frm );
6892 
6893  int base = (frm<0)?BASE_OFFSET_DYNAMIC:BASE_OFFSET_STATIC;
6895  frm = abs(frm);
6896  for (; frm; frm--)
6897  static_link = *(int*) ((char*) static_link + base);
6898 
6899  RETURN( USE(*(atom_t*) ((char*) static_link + (ofs*sizeof(atom_t))) ) );
6900 }
6901 
6902 
6903 
6904 
6905 //===================================================
6912 //===================================================
6913 
6915 {
6916  RETURN( unbound );
6917 }
6918 
6919 
6920 //===================================================
6928 // return its var atom.
6937 //===================================================
6938 
6939 atom_t RUNTIME rt_load( atom_t data )
6940 {
6941  RETURN( unbound );
6942 }
6943 
6944 
6945 
6946 //===================================================
6953 //===================================================
6954 
6956 {
6958 }
6959 
6960 
6961 
6962 //===================================================
6973 //===================================================
6974 
6975 atom_t RUNTIME rt_openfile_mode( atom_t filename, char* mode, int call_mode )
6976 {
6977  CHECK_PARAM( filename );
6978 
6979  // find a slot for the new file
6980  int i = find_file_by_handle( NULL );
6981  #ifdef SAFEMODE
6982  assert( i>-1 );
6983  #endif
6984 
6985  atom_t fn = atom_to_real_word( filename );
6986  if( IS_ERROR(fn) ) RETURN(fn);
6987 
6988  file_names[i] = FILENAME(STRING(fn));
6989  file_handles[i] = fopen( file_names[i], mode );
6990  if( errno )
6991  {
6992  DEUSE( fn );
6993  DEALLOC( file_names[i] );
6994  file_names[i] = NULL;
6995  file_handles[i] = NULL;
6996 
6997  last_os_error = errno;
6998  RETURN( new_error( ERROR_OS_ERROR, filename ) );
6999  }
7000 
7001  DEUSE( fn );
7002 
7003  if( call_mode==COMPILE_AS_FUNC )
7004  {
7005  RETURN( new_integer( (int)file_handles[i] ) );
7006  }
7007  else
7008  {
7009  RETURN( unbound );
7010  }
7011 };
7012 
7013 
7014 
7015 
7016 //===================================================
7028 //===================================================
7029 
7030 atom_t RUNTIME rt_openfile (atom_t mode, atom_t filename, int call_mode)
7031 {
7032  if( IS_ERROR(mode) ) RETURN(USE(mode));
7033 
7034  atom_t rw = atom_to_real_word( mode );
7035  if( IS_ERROR(rw) ) { RETURN(rw); }
7036 
7037  char* ascii_rw = FILENAME(STRING(rw));
7038 
7039  DEUSE( rw );
7040 
7041  atom_t res = rt_openfile_mode( filename, ascii_rw, call_mode );
7042 
7043  DEALLOC( ascii_rw );
7044 
7045  RETURN( res );
7046 };
7047 
7048 
7049 
7050 //===================================================
7067 //===================================================
7068 atom_t RUNTIME get_file_index( atom_t file, int* index )
7069 {
7070  *index = -1;
7071  if( IS_ERROR(file) ) RETURN(USE(file));
7072 
7073  int64_t handle;
7074  if( atom_to_int( file, &handle ) )
7075  { // the filename is a number
7076  *index = find_file_by_handle( (FILE*)(int)handle );
7077  }
7078 
7079  if( *index<0 )
7080  { // the filename may be a string
7081  atom_t fn = atom_to_real_word( file );
7082  if( IS_ERROR(fn) ) {DEUSE(fn); RETURN(USE(file))};
7083  char* ch = FILENAME(STRING(fn));
7084  *index = find_file_by_filename( ch );
7085  DEALLOC( ch );
7086  DEUSE( fn );
7087  }
7088 
7089  //is file opened?
7090  if( *index<0 )
7091  {
7093  }
7094 
7095  RETURN( unbound );
7096 };
7097 
7098 
7099 
7100 //===================================================
7110 //===================================================
7111 
7113 {
7114  int index;
7115  atom_t res = get_file_index( file, &index );
7116  if( IS_ERROR(res) ) RETURN(res); // USE is done by get_file_index()
7117 
7118  FILE *h = file_handles[index];
7120  if( h==input_stream ) input_stream = NULL;
7121  fclose( h );
7122 
7123  DEALLOC( file_names[index] );
7124  file_names[index] = NULL;
7125  file_handles[index] = NULL;
7126 
7127  RETURN( unbound );
7128 };
7129 
7130 
7131 //===================================================
7149 //===================================================
7150 
7151 atom_t RUNTIME rt_readblock( int static_link, atom_t parent, atom_t size )
7152 {
7153  int64_t datasize; // data size
7154  atom_t sizeatom;
7155 
7156  CHECK_PARAM( size );
7157 
7159  RETURN( empty_list );
7160 
7161  // try to get the block size
7162  if( IS_LIST( size ) )
7163  { // size is a prototype
7164  sizeatom = rt_blocksize( static_link, parent, size );
7165  if( IS_ERROR(sizeatom) )
7166  {
7167  RETURN( sizeatom );
7168  }
7169  datasize = INTEGER(sizeatom);
7170  }
7171  else
7172  { // size must be an integer
7173  if (!atom_to_int( size, &datasize ))
7174  {
7176  }
7177  sizeatom = USE(size);
7178  }
7179 
7180  atom_t data = new_mem( datasize );
7181 
7182  if( !fread( MEMORY(data), datasize, 1, input_stream ) )
7183  {
7184  DEUSE( data );
7185  DEUSE( sizeatom );
7186  if( errno )
7187  {
7188  errno = EIO;
7189  last_os_error = errno;
7190  return new_error( ERROR_OS_ERROR, size );
7191  }
7192  else
7193  {
7194  data = empty_list;
7195  }
7196  }
7197  else
7198  {
7199  DEUSE( ATOMS(data) );
7200  ATOMS(data) = sizeatom;
7201  }
7202  RETURN( data );
7203 };
7204 
7205 
7206 
7207 //===================================================
7223 //===================================================
7224 
7225 atom_t RUNTIME rt_readinblock( atom_t block, int call_mode )
7226 {
7227  CHECK_PARAM( block );
7228 
7229  if( input_stream==NULL )
7230  RETURN( empty_list );
7231 
7232  // try to get the block size
7233  if( !IS_MEM(block) || !IS_INTEGER(ATOMS(block)) )
7234  {
7236  }
7237 
7238  if( !fread( MEMORY(block), INTEGER(ATOMS(block)), 1, input_stream ) )
7239  {
7240  if( errno )
7241  {
7242  errno = EIO;
7243  last_os_error = errno;
7244  return new_error( ERROR_OS_ERROR, block );
7245  }
7246  else
7247  {
7248  if( call_mode==COMPILE_AS_FUNC )
7249  { RETURN( empty_list ); }
7250  else
7251  { RETURN( unbound ); }
7252  }
7253  }
7254 
7255  if( call_mode==COMPILE_AS_FUNC )
7256  { RETURN( USE(block) ); }
7257  else
7258  { RETURN( unbound ); }
7259 };
7260 
7261 
7262 
7263 //===================================================
7277 //===================================================
7278 
7280 {
7281  int64_t size; // data size
7282 
7283  if( IS_ERROR(data) ) RETURN(USE(data));
7284 
7285  if( output_stream==NULL )
7287 
7288  if( !IS_MEM(data) )
7289  {
7290  RETURN( new_error( ERROR_NOT_A_MEM, data ) );
7291  }
7292  if (!atom_to_int( ATOMS(data), &size ))
7293  {
7295  }
7296 
7297  fwrite( MEMORY(data), size, 1, output_stream );
7298  if( errno )
7299  {
7300  last_os_error = errno;
7301  RETURN( new_error( ERROR_OS_ERROR, data ) );
7302  }
7303 
7304  RETURN( unbound );
7305 };
7306 
7307 
7308 
7309 //===================================================
7317 //===================================================
7318 
7319 atom_t RUNTIME rt_readchar( void )
7320 {
7321  char_t ch = inner();
7322  if( ch==NO_MORE )
7323  {
7324  RETURN( empty_list );
7325  }
7326  else
7327  {
7328  RETURN( new_word( &ch, 1 ) );
7329  }
7330 }
7331 
7332 
7333 
7334 //===================================================
7343 //===================================================
7344 
7346 {
7347  atom_t res;
7348  int64_t count;
7349  chars_t chs;
7350 
7351  // parameters check
7352  if (IS_ERROR( data )) RETURN( USE(data) );
7353  GET_INT( data, count );
7354 
7355  if (count <= 0)
7356  {
7357  RETURN( new_error( ERROR_NOT_A_NUMBER, data ) );
7358  }
7359 
7360  // Allocate memory
7361  res = create_word( count+1 ); // +1 is for the terminating 0
7362  chs = STRING(res);
7363  while( count )
7364  {
7365  *chs = (char_t)inner();
7366  chs++;
7367  count--;
7368  }
7369  *chs = TEXT('\0');
7370 
7371  RETURN( res );
7372 }
7373 
7374 
7375 
7376 //===================================================
7384 //===================================================
7385 
7387 {
7388  chars_t buffer = 0; // buffer to hold the text
7389  int bufspace = 0; // number of free positions in the buffer
7390  int bufsize = 0; // current buffer size
7391  int bufstep = 16; // step size for buffer reallocations
7392  int buflen = 0;
7393  atom_t res;
7394 
7395  char_t ch = inner();
7396  if( ch==NO_MORE )
7397  {
7398  return( empty_list );
7399  }
7400 
7401  while( (ch!=TEXT('\n')) && (ch!=NO_MORE) )
7402  {
7403  if( !bufspace )
7404  {
7405  buffer = REALLOC( buffer, (bufsize+bufstep)*sizeof(char_t) );
7406  bufspace = bufstep;
7407  bufsize = bufsize+bufstep;
7408  bufstep = bufstep+1;
7409  }
7410 
7411  *(buffer+buflen) = ch;
7412  buflen++;
7413  bufspace--;
7414 
7415  ch = inner();
7416  }
7417 
7418  if( !buffer ) return( empty_list );
7419  res = new_word( buffer, buflen );
7420  DEALLOC( buffer );
7421  return res;
7422 }
7423 
7424 
7425 
7426 //===================================================
7435 //===================================================
7436 
7437 atom_t RUNTIME rt_readword( void )
7438 {
7439  atom_t word = rt_readrawline();
7440  if( IS_ERROR(word) ) return word;
7441  if( IS_EMPTY(word) ) return word;
7442 
7443  atom_t parsed = tokenize( word, TOKENIZE_READWORD );
7444  DEUSE( word );
7445  return parsed;
7446 }
7447 
7448 
7449 
7450 //===================================================
7459 //===================================================
7460 
7461 atom_t RUNTIME rt_readlist( void )
7462 {
7463  atom_t word = rt_readrawline();
7464  if( IS_ERROR(word) ) return word;
7465  if( IS_EMPTY(word) ) return new_word( TEXT(""), 0);
7466 
7467  atom_t parsed = tokenize( word, TOKENIZE_READLIST );
7468  DEUSE( word );
7469  return parsed;
7470 }
7471 
7472 
7473 
7474 //===================================================
7484 //===================================================
7485 
7487 {
7488  atom_t res;
7489 
7490  if (IS_ERROR( data )) RETURN( USE(data) );
7491 
7492  atom_t word = atom_to_word( data );
7493  if (IS_ERROR( word )) RETURN( word );
7494 
7495  char* varname = UTF16_to_ASCII( STRING(word) );
7496  varname[LENGTH(word)] = '\0';
7497  //printf("varname=|%s| len=%d\n",varname,strlen(varname));
7498  char* asciivalue = getenv( varname );
7499  //printf("asciivalue=%s\n",asciivalue);
7500  if( asciivalue )
7501  {
7502  chars_t value = ASCII_to_UTF16( asciivalue );
7503  res = new_word( value, -1 );
7504  DEALLOC( value );
7505  }
7506  else
7507  {
7508  res = empty_list;
7509  }
7510 
7511  DEUSE( word );
7512  DEALLOC( varname );
7513  RETURN( res );
7514 }
7515 
7516 
7517 
7518 //===================================================
7525 //===================================================
7526 
7528 {
7529  atom_t res = empty_list;
7530  char oldv;
7531 
7532 #ifdef environ
7533  char** env = environ;
7534 #else
7535  char** env = __environ;
7536 #endif
7537 
7538  while( (*env) )
7539  {
7540  char* var = *env;
7541  char* v=var;
7542  while( (*v!='=') && (*v!='\n') ) v++;
7543  oldv = *v;
7544  *v = '\0';
7545  chars_t uname = ASCII_to_UTF16( var );
7546  chars_t uvalue = ASCII_to_UTF16( v+1 );
7547  *v = oldv;
7548 
7549  atom_t pair = new_list( new_word(uvalue,-1), empty_list );
7550  pair = new_list( new_word(uname,-1), pair );
7551  res = new_list( pair, res );
7552 
7553  DEALLOC( uname );
7554  DEALLOC( uvalue );
7555  env++;
7556  }
7557  RETURN( res );
7558 }
7559 
7560 
7561 //===================================================
7569 //===================================================
7570 
7571 atom_t RUNTIME rt_eofp( void )
7572 {
7573  RETURN ( USE(false_true[inner_eof()]) );
7574 }
7575 
7576 
7577 
7578 //===================================================
7586 //===================================================
7587 
7589 {
7590  atom_t res;
7591  char path[PATH_MAX+1];
7592 
7593  char* p = getcwd( path, PATH_MAX );
7594  if( p )
7595  {
7596  chars_t pathwc = UNFILENAME( path );
7597  res = new_word(pathwc,-1);
7598  DEALLOC( pathwc);
7599  }
7600  else
7601  {
7602  res = new_os_error_atom( unbound );
7603  }
7604  RETURN( res );
7605 }
7606 
7607 
7608 
7609 //===================================================
7618 //===================================================
7619 
7621 {
7622  atom_t res;
7623 
7624  if (IS_ERROR( name )) RETURN( USE(name) );
7625  atom_t word = atom_to_real_word( name );
7626 
7627  char* fname = FILENAME( STRING(word) );
7628  int err;
7629  #ifdef WINDOWS
7630  err = mkdir( fname );
7631  #else
7632  err = mkdir( fname, (S_IRWXU|S_IRWXG|S_IRWXO) );
7633  #endif
7634 
7635  if( err )
7636  res = new_os_error_atom( name );
7637  else
7638  res = unbound;
7639 
7640  DEUSE( word );
7641  DEALLOC( fname );
7642 
7643  RETURN( res );
7644 }
7645 
7646 
7647 
7648 //===================================================
7657 //===================================================
7658 
7660 {
7661  atom_t res;
7662 
7663  if (IS_ERROR( name )) RETURN( USE(name) );
7664  atom_t word = atom_to_real_word( name );
7665 
7666  char* fname = FILENAME( STRING(word) );
7667  int err = rmdir( fname );
7668 
7669  if( err )
7670  res = new_os_error_atom( name );
7671  else
7672  res = unbound;
7673 
7674  DEUSE( word );
7675  DEALLOC( fname );
7676 
7677  RETURN( res );
7678 }
7679 
7680 
7681 
7682 //===================================================
7691 //===================================================
7692 
7694 {
7695  atom_t res;
7696 
7697  if (IS_ERROR( name )) RETURN( USE(name) );
7698  atom_t word = atom_to_real_word( name );
7699 
7700  char* fname = FILENAME( STRING(word) );
7701  int err = chdir( fname );
7702 
7703  if( err )
7704  res = new_os_error_atom( name );
7705  else
7706  res = unbound;
7707 
7708  DEUSE( word );
7709  DEALLOC( fname );
7710 
7711  RETURN( res );
7712 }
7713 
7714 
7715 
7716 //===================================================
7725 //===================================================
7726 
7728 {
7729  atom_t res;
7730 
7731  if (IS_ERROR( name )) RETURN( USE(name) );
7732  atom_t word = atom_to_real_word( name );
7733 
7734  char* fname = FILENAME( STRING(word) );
7735 
7736  struct stat buffer;
7737  int err = stat( fname, &buffer );
7738 
7739  if( err )
7740  res = USE(false_true[0]);
7741  else
7742  res = USE(false_true[ S_ISDIR(buffer.st_mode)?1:0 ]);
7743 
7744  DEUSE( word );
7745  DEALLOC( fname );
7746 
7747  RETURN( res );
7748 }
7749 
7750 
7751 
7752 
7753 //===================================================
7763 //===================================================
7764 
7765 atom_t RUNTIME rt_renamefolder_or_file( atom_t toname, atom_t fromname, int folders )
7766 {
7767  atom_t res;
7768 
7769  if (IS_ERROR( fromname )) RETURN( USE(fromname) );
7770  if (IS_ERROR( toname )) RETURN( USE(toname) );
7771 
7772  atom_t fword = atom_to_real_word( fromname );
7773  atom_t tword = atom_to_real_word( toname );
7774 
7775  char* fname = FILENAME( STRING(fword) );
7776  char* tname = FILENAME( STRING(tword) );
7777 
7778  struct stat buffer;
7779  int err = stat( fname, &buffer );
7780 
7781  int ok;
7782  if( folders )
7783  ok = S_ISDIR(buffer.st_mode);
7784  else
7785  ok = S_ISREG(buffer.st_mode);
7786 
7787  if( ok )
7788  err = rename( fname, tname );
7789 
7790  if( err )
7791  res = new_os_error_atom( fromname );
7792  else
7793  res = unbound;
7794 
7795  DEUSE( fword );
7796  DEUSE( tword );
7797  DEALLOC( fname );
7798  DEALLOC( tname );
7799 
7800  RETURN( res );
7801 }
7802 
7803 
7804 
7805 //===================================================
7815 //===================================================
7816 
7817 atom_t RUNTIME rt_renamefolder( atom_t toname, atom_t fromname )
7818 {
7819  atom_t res;
7820 
7821  res = rt_renamefolder_or_file( toname, fromname, 1 );
7822 
7823  RETURN( res );
7825 
7826 
7827 
7828 //===================================================
7838 //===================================================
7839 
7840 atom_t RUNTIME rt_renamefile( atom_t toname, atom_t fromname )
7841 {
7842  atom_t res;
7843 
7844  res = rt_renamefolder_or_file( toname, fromname, 0 );
7845 
7846  RETURN( res );
7848 
7849 
7850 
7851 //===================================================
7860 //===================================================
7861 
7862 atom_t RUNTIME rt_folders_or_files( atom_t name, int folders )
7863 {
7864  // assume the result is empty list
7865  atom_t res = empty_list;
7866 
7867  // convert the folder name into ASCII
7868  if (IS_ERROR( name )) RETURN( USE(name) );
7869  atom_t word = atom_to_real_word( name );
7870  char* fname = FILENAME( STRING(word) );
7871 
7872  // verify that this is really a folder
7873  struct stat buffer;
7874  int err = stat( fname, &buffer );
7875  if( !err && S_ISDIR(buffer.st_mode) )
7876  {
7877  // open the folder
7878  DIR *dp;
7879  struct dirent *de;
7880 
7881  dp = opendir( fname );
7882  if( dp )
7883  {
7884  char long_name[PATH_MAX];
7885  int len = strlen( fname );
7886  strcpy( long_name, fname );
7887  long_name[len] = '/';
7888  len++;
7889 
7890  // scan the files one by one
7891  atom_t last = empty_list;
7892  de = readdir( dp );
7893  while( de )
7894  {
7895  struct stat buffer;
7896  strcpy( long_name+len, de->d_name );
7897  int err = stat(long_name,&buffer);
7898  if( err==0 )
7899  {
7900  int ok;
7901  if( folders )
7902  ok = S_ISDIR(buffer.st_mode);
7903  else
7904  ok = S_ISREG(buffer.st_mode);
7905  if( ok )
7906  {
7907  chars_t buf = UNFILENAME(de->d_name);
7908  atom_t word = new_word( buf, -1 );
7909  append( word, &res, &last );
7910  DEALLOC( buf );
7911  }
7912  }
7913  de = readdir( dp );
7914  }
7915  closedir( dp );
7916  }
7917  }
7918 
7919  DEUSE( word );
7920  DEALLOC( fname );
7921 
7922  RETURN( res );
7923 }
7924 
7925 
7926 
7927 //===================================================
7935 //===================================================
7936 
7938 {
7939  atom_t res = rt_folders_or_files( name, 1 );
7940  RETURN( res );
7941 }
7942 
7943 
7945 
7946 //===================================================
7954 //===================================================
7955 
7956 atom_t RUNTIME rt_files( atom_t name )
7957 {
7958  atom_t res = rt_folders_or_files( name, 0 );
7959  RETURN( res );
7960 }
7961 
7962 
7964 
7965 //===================================================
7974 //===================================================
7975 
7977 {
7978  atom_t res;
7979 
7980  if (IS_ERROR( name )) RETURN( USE(name) );
7981  atom_t word = atom_to_real_word( name );
7982 
7983  char* fname = FILENAME( STRING(word) );
7984  int err = unlink( fname );
7985 
7986  if( err )
7987  res = new_os_error_atom( name );
7988  else
7989  res = unbound;
7990 
7991  DEUSE( word );
7992  DEALLOC( fname );
7993 
7994  RETURN( res );
7995 }
7996 
7997 
7998 
7999 
8000 //===================================================
8009 //===================================================
8010 
8011 atom_t RUNTIME rt_filep( atom_t name )
8012 {
8013  atom_t res;
8014 
8015  if (IS_ERROR( name )) RETURN( USE(name) );
8016  atom_t word = atom_to_real_word( name );
8017 
8018  char* fname = FILENAME( STRING(word) );
8019 
8020  struct stat buffer;
8021  int err = stat( fname, &buffer );
8022 
8023  if( err )
8024  res = USE(false_true[0]);
8025  else
8026  res = USE(false_true[ S_ISREG(buffer.st_mode)?1:0 ]);
8027 
8028  DEUSE( word );
8029  DEALLOC( fname );
8030 
8031  RETURN( res );
8032 }
8033 
8034 
8035 
8036 //===================================================
8045 //===================================================
8046 
8048 {
8049  atom_t res;
8050 
8051  if (IS_ERROR( name )) RETURN( USE(name) );
8052  atom_t word = atom_to_real_word( name );
8053 
8054  char* fname = FILENAME( STRING(word) );
8055 
8056  struct stat buffer;
8057  int err = stat( fname, &buffer );
8058 
8059  if( err )
8060  res = new_integer( -1 );
8061  else
8062  res = new_integer( buffer.st_size );
8063 
8064  DEUSE( word );
8065  DEALLOC( fname );
8066 
8067  RETURN( res );
8068 }
8069 
8070 
8071 
8072 
8073 //===================================================
8084 //===================================================
8085 
8087 {
8088  atom_t res;
8089 
8090  if (IS_ERROR( name )) RETURN( USE(name) );
8091  atom_t word = atom_to_real_word( name );
8092 
8093  char* fname = FILENAME( STRING(word) );
8094 
8095  struct stat buffer;
8096  int err = stat( fname, &buffer );
8097 
8098  res = empty_list;
8099  if( !err )
8100  {
8101  res = new_list( new_integer( buffer.st_atime ), res );
8102  res = new_list( new_integer( buffer.st_mtime ), res );
8103  res = new_list( new_integer( buffer.st_ctime ), res );
8104  }
8105 
8106  DEUSE( word );
8107  DEALLOC( fname );
8108 
8109  RETURN( res );
8110 }
8111 
8112 
8113 
8114 
8115 //===================================================
8125 //===================================================
8126 
8127 atom_t RUNTIME rt_openread( atom_t name, int call_mode )
8128 {
8129  atom_t res = rt_openfile_mode( name, "r", call_mode );
8130  RETURN( res );
8131 }
8132 
8133 
8135 
8136 //===================================================
8146 //===================================================
8147 
8148 atom_t RUNTIME rt_openwrite( atom_t name, int call_mode )
8149 {
8150  atom_t res = rt_openfile_mode( name, "w", call_mode );
8151  RETURN( res );
8152 }
8153 
8154 
8156 
8157 
8158 //===================================================
8168 //===================================================
8169 
8170 atom_t RUNTIME rt_openappend( atom_t name, int call_mode )
8171 {
8172  atom_t res = rt_openfile_mode( name, "a", call_mode );
8173  RETURN( res );
8174 }
8175 
8176 
8178 
8179 //===================================================
8189 //===================================================
8190 
8191 atom_t RUNTIME rt_openupdate( atom_t name, int call_mode )
8192 {
8193  atom_t res = rt_openfile_mode( name, "r+", call_mode );
8194  RETURN( res );
8195 }
8196 
8197 
8199 //===================================================
8209 //===================================================
8211 {
8212  // empty list resets the reader
8213  if( file==empty_list )
8214  {
8215  input_stream = NULL;
8216  }
8217  else
8218  {
8219  int index;
8220  atom_t res = get_file_index( file, &index );
8221  if( IS_ERROR(res) ) RETURN(res); // USE is done by get_file_index()
8222 
8223  input_stream = file_handles[index];
8224  }
8225 
8226  RETURN( unbound );
8227 };
8228 
8229 
8230 
8231 
8232 //===================================================
8242 //===================================================
8244 {
8245  // empty list resets the reader
8246  if( file==empty_list )
8247  {
8248  output_stream = NULL;
8249  }
8250  else
8251  {
8252  int index;
8253  atom_t res = get_file_index( file, &index );
8254  if( IS_ERROR(res) ) RETURN(res); // USE is done by get_file_index()
8255 
8256  output_stream = file_handles[index];
8257  }
8258 
8259  RETURN( unbound );
8260 };
8261 
8262 
8263 
8264 
8265 //===================================================
8273 //===================================================
8275 {
8276  atom_t res;
8277 
8278  if( input_stream==NULL )
8279  {
8280  res = empty_list;
8281  }
8282  else
8283  {
8284  int i = find_file_by_handle( input_stream );
8285  #ifdef SAFEMODE
8286  assert( i>-1 );
8287  #endif
8288  chars_t name = ASCII_to_UTF16( file_names[i] );
8289  res = new_word( name, -1 );
8290  DEALLOC( name );
8291  }
8292 
8293  RETURN( res );
8294 };
8295 
8296 
8297 
8298 //===================================================
8306 //===================================================
8308 {
8309  atom_t res;
8310 
8311  if( output_stream==NULL )
8312  {
8313  res = empty_list;
8314  }
8315  else
8316  {
8318  #ifdef SAFEMODE
8319  assert( i>-1 );
8320  #endif
8321  chars_t name = ASCII_to_UTF16( file_names[i] );
8322  res = new_word( name, -1 );
8323  DEALLOC( name );
8324  }
8325 
8326  RETURN( res );
8327 };
8328 
8329 
8330 
8331 //===================================================
8338 //===================================================
8340 {
8341  atom_t res = empty_list;
8342  atom_t last = empty_list;
8343 
8344  int i;
8345  for( i=0; i<FOPEN_MAX; i++ )
8346  if( file_handles[i] )
8347  {
8348  chars_t name = ASCII_to_UTF16( file_names[i] );
8349  atom_t word = new_word( name, -1 );
8350  DEALLOC( name );
8351 
8352  append( word, &res, &last );
8353  }
8354 
8355  RETURN( res );
8356 };
8357 
8358 
8359 
8360 //===================================================
8367 //===================================================
8369 {
8370  int i;
8371  for( i=0; i<FOPEN_MAX; i++ )
8372  if( file_handles[i] )
8373  {
8374  DEALLOC( file_names[i] );
8375  fclose( file_handles[i] );
8376  file_names[i] = NULL;
8377  file_handles[i] = NULL;
8378  }
8379 
8380  RETURN( unbound );
8381 };
8382 
8383 
8384 
8385 //===================================================
8395 //===================================================
8397 {
8398  int64_t position;
8399  GET_INT( pos, position );
8400  if( position>=0 )
8401  {
8402  fseek( input_stream, position, SEEK_SET );
8403  }
8404  else
8405  {
8406  fseek( input_stream, position, SEEK_END );
8407  }
8408 
8409  RETURN( unbound );
8410 };
8411 
8412 
8413 
8414 
8415 //===================================================
8422 //===================================================
8424 {
8425  int pos;
8426 
8427  if( input_stream==NULL )
8428  pos = 0;
8429  else
8430  pos = ftell( input_stream );
8431 
8432  RETURN( new_integer(pos) );
8433 };
8434 
8435 
8436 
8437 //===================================================
8447 //===================================================
8449 {
8450  int64_t position;
8451  GET_INT( pos, position );
8452  if( position>=0 )
8453  fseek( output_stream, position, SEEK_SET );
8454  else
8455  fseek( output_stream, position, SEEK_END );
8456 
8457  RETURN( unbound );
8458 };
8459 
8460 
8461 
8462 
8463 //===================================================
8470 //===================================================
8472 {
8473  int pos;
8474 
8475  if( output_stream==NULL )
8476  pos = 0;
8477  else
8478  pos = ftell( output_stream );
8479 
8480  RETURN( new_integer(pos) );
8481 };
8482 
8483 
8484 
8485 //===================================================
8492 //===================================================
8494 {
8495  RETURN( new_integer(-timezone) );
8496 };
8497 
8498 
8499 
8500 //===================================================
8507 //===================================================
8508 
8510 {
8511  if( dribble_handle )
8512  {
8513  fclose( dribble_handle );
8514  }
8515  dribble_handle = NULL;
8517  RETURN( unbound );
8518 };
8519 
8520 
8521 
8522 //===================================================
8533 //===================================================
8535 {
8536  CHECK_PARAM( file );
8537 
8538  atom_t fn = atom_to_real_word( file );
8539  if( IS_ERROR(fn) ) RETURN(fn);
8540 
8542 
8543  char* file_name = FILENAME(STRING(fn));
8544  dribble_handle = fopen( file_name, "w" );
8545  if( errno )
8546  {
8547  DEUSE( fn );
8548  DEALLOC( file_name );
8549  dribble_handle = NULL;
8550 
8551  last_os_error = errno;
8552  RETURN( new_error( ERROR_OS_ERROR, file ) );
8553  }
8554 
8555  DEALLOC( file_name );
8556  DEUSE( fn );
8557  RETURN( unbound );
8558 };

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