Lhogho  0.0.028
 All Data Structures Files Functions Variables Typedefs Macros Pages
vars.c
Go to the documentation of this file.
1 //
2 // Project: Lhogho
3 // File: vars.c
4 //
5 // Copyright (C) 2007 P.Boytchev
6 //
7 // Revision history:
8 // 2007-02-27 - file created
9 // 2007-05-17 - added license info
10 // 2007-05-22 - added doxygen-friendly documentation
11 // 2007-05-26 - calling primitives' finalization
12 // 2007-05-29 - root var defined as a function
13 // - find_local_var()
14 // 2007-06-05 - definitions spread to where they belong
15 // 2007-06-09 - added dump_var()
16 // - fixed bug #1734095 (Cannot dump vars)
17 // 2007-06-11 - process option_user_variables
18 // 2007-06-18 - new_local_var()
19 // 2007-06-24 - fixed bug #1742361 (Memory leak using LOCAL)
20 // 2007-08-08 - Added addresses of arithmetical and trigonometric primitives
21 // 2007-08-13 - globals
22 // - rt_printdepthlimit, rt_printwidthlimit, rt_fullprintp
23 // 2007-09-03 - Fixed bug #1787023 ARCTAN and RADARCTAN
24 // 2007-09-15 - Added addresses of comparison operators and primitives
25 // 2007-09-15 - global rt_caseignoredp
26 // 2007-09-17 - Added addresses of AND, OR, NOT
27 // 2007-09-18 - Support for OUTPUT, STOP
28 // 2007-09-19 - Support for IGNORE
29 // 2007-09-19 - Support for FIRST BUTFIRST
30 // 2007-09-21 - Support for LAST BUTLAST ITEM
31 // 2007-09-23 - Support for IF, IFELSE
32 // - Support for PARSE, RUNPARSE
33 // 2007-09-26 - Support for WORDP, LISTP, NUMBERP, EMPTYP
34 // 2007-09-27 - Support for MEMBERP
35 // - Support for WORD, LIST, SENTENCE, SE, LPUT, FPUT
36 // 2007-09-29 - Support for REPEAT
37 // 2007-10-10 - Fixed bug #1806484 Wrobg variable's offset
38 // 2007-10-13 - Support for COUNT, CHAR, ASCII, LOWERCASE, UPPERCASE, MEMBER
39 // 2007-10-21 - Support for FOREVER
40 // 2007-10-23 - Support for REPCOUNT
41 // 2007-10-28 - Support for RANDOM, RERANDOM, ISEQ, RSEQ
42 // 2007-10-28 - Support for TYPE, SHOW, FORM, FORMAT
43 // 2007-11-04 - Support for WHILE, UNTIL
44 // 2007-11-06 - Support for DO.WHILE, DO.UNTIL
45 // - Support for DEFINED?, DEFINEDP
46 // - Support for PRIMITIVE?, PRIMITIVEP
47 // - Support for PROCEDURE?, PROCEDUREP
48 // - Support for LOGOPLATFORM, LOGOVERSION, LOGODIALECT
49 // - Support for THING
50 // 2007-11-10 - Fixed bug #1828881 Test case make-05.lgo
51 // - Fixed bug #1828897 Problem with indirect MAKE
52 // 2007-11-11 - Support for WAIT and BYE
53 // - Support for NAME
54 // 2007-11-12 - Support for CATCH, THROW
55 // 2007-11-21 - Support for TEST, IFTRUE, IFFALSE
56 // 2007-12-02 - Support for BACKSLASHED?
57 // 2007-12-03 - Support for TEXT, FULLTEXT
58 // 2007-12-15 - Support for LSHIFT, ASHIFT, BITAND, BITOR, BITXOR, BITNOT
59 // 2007-12-16 - Support for PICK, REMDUP, REMOVE, REVERSE,
60 // RAWASCII, GENSYM, SUBSTRINGP
61 // 2007-12-22 - Support for RUN
62 // 2007-12-30 - Support for COMBINE
63 // 2008-01-07 - Fixed bug #1856864 Defined but unset variables
64 // - Support for RUNRESULT
65 // 2008-03-22 - Support for QUOTED
66 // 2008-08-17 - Support for FIRSTS, BUTFIRSTS, BFS
67 // 2008-08-23 - Support for FOR
68 // 2008-09-05 - Support for LIBLOAD, LIBFREE
69 // - Support for PACKSIZE, PACK, UNPACK
70 // 2008-09-09 - Support for EXTERNAL
71 // 2008-09-18 - Support for INTERNAL
72 // 2008-11-21 - Support for PACKOPEN, PACKCLOSE, PACKREAD, PACKWRITE
73 // 2009-05-16 - Support for ABS
74 // 2009-05-18 - Support for COMMANDLINE
75 // 2009-06-03 - Support for READCHAR, READCHARS, GETENV, GETENVS
76 // 2009-08-03 - Fixed bug #2191139 Errors/exits in internal functions
77 // - Support for READRAWLINE
78 // 2009-08-04 - Support for READWORD, READLIST
79 // 2009-08-16 - Fixed bug #2838617 RUN suppresses STOP
80 // 2009-08-19 - Support for MAYBEOUTPUT
81 // 2009-08-20 - Support for _STACKFRAME, _STACKFRAMEATOM
82 // 2009-08-29 - Fixed bug #2845099 Memory leak in THROW
83 // - Fixed bug #2845579 DEBUG_MEMORY_LEAKS finds two bad tests
84 // - Fixed bug #2846281 Errors not (de)used correctly
85 // 2010-06-25 - Support for EOF?,EOFP
86 // 2011-02-05 - Renamed PACKOPEN, PACKCLOSE, PACKREAD, PACKWRITE
87 // 2011-02-28 - Fixed bug #3195253 product 2 7
88 // 2011-03-02 - Fixed bug #3197401 Warnings and errors compiling the developer's documentation
89 // 2011-04-16 - Fixed bug #3279870 sum 1 2
90 // 2011-10-14 - Support for RUNMACRO
91 // 2011-10-22 - Fixed bug #3427251 Indirect MAKE and LOCAL cause a crash
92 // 2011-10-29 - Fixed bug #3427254 Indirect MAKE and LOCAL in RUNMACRO cause a crash
93 // 2011-12-26 - Support for SUBSTRING
94 // 2012-01-01 - Fixed bug #3468189 Doxygen warnings
95 // 2012-01-01 - Adding synonyms for FIRST FIRSTS LAST LASTS
96 // 2012-01-02 - Command-line options are translatable
97 // 2012-01-05 - More synonyms for primitives
98 // 2012-01-19 - Support for CURRENTFOLDER, MAKEFOLDER
99 // 2012-01-20 - Support for ERASEFOLDER, FOLDER?, FOLDERP, RENAMEFOLDER
100 // 2012-01-21 - Support for FOLDERS, CHANGEFOLDER
101 // 2012-01-23 - Support for FILES, ERASEFILE, FILE?, FILEP, RENAMEFILE
102 // FILESIZE, FILETIMES, FORMATTIME
103 // 2012-01-24 - Support for OPENREAD, OPENWRITE, OPENAPPEND, OPENUPDATE
104 // SETREAD, SETWRITE
105 // 2012-01-25 - Support for READER, WRITER, ALLOPEN
106 // 2012-01-27 - Support for CLOSEALL, READPOS, SETREADPOS, WRiTEPOS, SETWRITEPOS
107 // 2012-01-31 - Support for TIMEZONE
108 // 2012-02-05 - Support for READINBLOCK
109 // 2012-02-09 - Support for DRIBBLE, NODRIBBLE
110 // 2012-02-26 - Fixed bug #3493871 Externals do not capture errors
111 //
112 //
113 // This program is free software; you can redistribute it and/or modify
114 // it under the terms of the GNU General Public License as published by
115 // the Free Software Foundation; either version 2 of the License, or
116 // (at your option) any later version.
117 //
118 // This program is distributed in the hope that it will be useful,
119 // but WITHOUT ANY WARRANTY; without even the implied warranty of
120 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
121 // GNU General Public License for more details.
122 //
123 // You should have received a copy of the GNU General Public License
124 // along with this program; if not, write to the Free Software
125 // Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
126 //
127 
128 #include <assert.h> // assert()
129 #include <stdio.h>
130 #include "globals.h"
131 #include "atoms.h"
132 #include "words.h"
133 #include "lists.h"
134 #include "numbers.h"
135 #include "unicode.h"
136 #include "parser.h"
137 #include "translate.h"
138 #include "vars.h"
139 #include "pools.h"
140 #include "options.h"
141 #include "errors.h"
142 #include "runtime.h"
143 #include "compiler.h"
144 
145 
156 
159 
162 
167 
170 
175 
176 //===================================================
183 //===================================================
184 
185 typedef struct prim_t {
186  fn function;
187  short largs;
188  short rargs;
189  int flags;
190 } primitive_t;
191 
192 
193 
194 #define FLAG_EX_PRINTDEPTHLIMIT 0x00010000
195 #define FLAG_EX_PRINTWIDTHLIMIT 0x00020000
196 #define FLAG_EX_FULLPRINTP 0x00040000
197 #define FLAG_EX_CASEIGNOREDP 0x00080000
198 #define FLAG_EX_LOGOPLATFORM 0x00100000
199 #define FLAG_EX_LOGOVERSION 0x00200000
200 #define FLAG_EX_LOGODIALECT 0x00400000
201 
202 // list of all primitives
204  {
205  // multiplicative operators
206  {(fn)rt_mul, 1, 1, FLAG_FUNCTION|FLAG_PRIORITY_MUL}, // *
207  {(fn)rt_div, 1, 1, FLAG_FUNCTION|FLAG_PRIORITY_MUL}, // /
208 
209  // additive operators
212 
213  // comare operators
215  {(fn)rt_less, 1, 1, FLAG_FUNCTION|FLAG_PRIORITY_CMP}, // <
216  {(fn)rt_more, 1, 1, FLAG_FUNCTION|FLAG_PRIORITY_CMP}, // >
220 
221  // logical operators and functions
226  {(fn)rt_not, 0, 1, FLAG_FUNCTION}, // not
227 
228  // primitive functions SELECTORS
229  {(fn)rt_first, 0, 1, FLAG_FUNCTION}, // first
230  {(fn)rt_first, 0, 1, FLAG_FUNCTION}, // first (synonym)
231  {(fn)rt_butfirst, 0, 1, FLAG_FUNCTION}, // butfirst
232  {(fn)rt_butfirst, 0, 1, FLAG_FUNCTION}, // bf
233  {(fn)rt_firsts, 0, 1, FLAG_FUNCTION}, // firsts
234  {(fn)rt_firsts, 0, 1, FLAG_FUNCTION}, // firsts (synonym)
235  {(fn)rt_butfirsts,0, 1, FLAG_FUNCTION}, // butfirsts
236  {(fn)rt_butfirsts,0, 1, FLAG_FUNCTION}, // bfs
237  {(fn)rt_last, 0, 1, FLAG_FUNCTION}, // last
238  {(fn)rt_last, 0, 1, FLAG_FUNCTION}, // last (synonym)
239  {(fn)rt_butlast, 0, 1, FLAG_FUNCTION}, // butlast
240  {(fn)rt_butlast, 0, 1, FLAG_FUNCTION}, // bl
241  {(fn)rt_item, 0, 2, FLAG_FUNCTION}, // item
242  {(fn)rt_item, 0, 2, FLAG_FUNCTION}, // item
243 
244  // primitive functions CONSTRUCTORS
245  {(fn)rt_word, 0, 2, FLAG_FUNCTION|FLAG_INFINITE_ARGS}, // word
246  {(fn)rt_list, 0, 2, FLAG_FUNCTION|FLAG_INFINITE_ARGS}, // list
247  {(fn)rt_sent, 0, 2, FLAG_FUNCTION|FLAG_INFINITE_ARGS}, // sentence
248  {(fn)rt_sent, 0, 2, FLAG_FUNCTION|FLAG_INFINITE_ARGS}, // se
249  {(fn)rt_fput, 0, 2, FLAG_FUNCTION}, // fput
250  {(fn)rt_fput, 0, 2, FLAG_FUNCTION}, // fput
251  {(fn)rt_lput, 0, 2, FLAG_FUNCTION}, // lput
252  {(fn)rt_lput, 0, 2, FLAG_FUNCTION}, // lput
253 
254  // primitive functions PREDICATES
255  {(fn)rt_wordp, 0, 1, FLAG_FUNCTION}, // word?
256  {(fn)rt_wordp, 0, 1, FLAG_FUNCTION}, // wordp
257  {(fn)rt_listp, 0, 1, FLAG_FUNCTION}, // list?
258  {(fn)rt_listp, 0, 1, FLAG_FUNCTION}, // listp
259  {(fn)rt_numberp, 0, 1, FLAG_FUNCTION}, // number?
260  {(fn)rt_numberp, 0, 1, FLAG_FUNCTION}, // numberp
261  {(fn)rt_empty, 0, 1, FLAG_FUNCTION}, // empty?
262  {(fn)rt_empty, 0, 1, FLAG_FUNCTION}, // emptyp
263  {(fn)rt_equal, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // equal?
264  {(fn)rt_equal, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // equalp
265  {(fn)rt_nequal, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // notequal?
266  {(fn)rt_nequal, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // notequalp
267  {(fn)rt_before, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // before?
268  {(fn)rt_before, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // beforep
269  {(fn)rt_less, 0, 2, FLAG_FUNCTION}, // less?
270  {(fn)rt_less, 0, 2, FLAG_FUNCTION}, // lessp
271  {(fn)rt_more, 0, 2, FLAG_FUNCTION}, // greater?
272  {(fn)rt_more, 0, 2, FLAG_FUNCTION}, // greaterp
273  {(fn)rt_lesseq, 0, 2, FLAG_FUNCTION}, // lessequal?
274  {(fn)rt_lesseq, 0, 2, FLAG_FUNCTION}, // lessequalp
275  {(fn)rt_moreeq, 0, 2, FLAG_FUNCTION}, // greaterequal?
276  {(fn)rt_moreeq, 0, 2, FLAG_FUNCTION}, // greaterequalp
277  {(fn)rt_memberp, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // member?
278  {(fn)rt_memberp, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // member?
279  {(fn)rt_memberp, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // memberp
280  {(fn)rt_memberp, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // memberp
281 
282  // queries
283  {(fn)rt_count, 0, 1, FLAG_FUNCTION}, // count
284  {(fn)rt_count, 0, 1, FLAG_FUNCTION}, // count
285  {(fn)rt_char, 0, 1, FLAG_FUNCTION}, // char
286  {(fn)rt_ascii, 0, 1, FLAG_FUNCTION}, // ascii
287  {(fn)rt_lower, 0, 1, FLAG_FUNCTION}, // lowercase
288  {(fn)rt_lower, 0, 1, FLAG_FUNCTION}, // lowercase
289  {(fn)rt_upper, 0, 1, FLAG_FUNCTION}, // uppercase
290  {(fn)rt_upper, 0, 1, FLAG_FUNCTION}, // uppercase
291  {(fn)rt_member, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // member
292  {(fn)rt_parse, 0, 1, FLAG_FUNCTION}, // parse
293  {(fn)rt_runparse, 0, 1, FLAG_FUNCTION}, // runparse
294 
295  // arithmetic
296  {(fn)rt_sum, 0, 2, FLAG_FUNCTION | FLAG_INFINITE_ARGS}, // sum
297  {(fn)rt_difference, 0, 2, FLAG_FUNCTION}, // difference
298  {(fn)rt_unminus, 0, 1, FLAG_FUNCTION}, // minus
299  {(fn)rt_product, 0, 2, FLAG_FUNCTION | FLAG_INFINITE_ARGS}, // product
300  {(fn)rt_div, 0, 2, FLAG_FUNCTION}, // div
301  {(fn)rt_remainder, 0, 2, FLAG_FUNCTION}, // remainder
302  {(fn)rt_int, 0, 1, FLAG_FUNCTION}, // int
303  {(fn)rt_round, 0, 1, FLAG_FUNCTION}, // round
304  {(fn)rt_sqrt, 0, 1, FLAG_FUNCTION}, // sqrt
305  {(fn)rt_power, 0, 2, FLAG_FUNCTION}, // power
306  {(fn)rt_exp, 0, 1, FLAG_FUNCTION}, // exp
307  {(fn)rt_log10, 0, 1, FLAG_FUNCTION}, // log10
308  {(fn)rt_ln, 0, 1, FLAG_FUNCTION}, // ln
309  {(fn)rt_abs, 0, 1, FLAG_FUNCTION}, // abs
310 
311  // trigonometric
312  {(fn)rt_pi, 0, 0, FLAG_FUNCTION}, // pi
313  {(fn)rt_sin, 0, 1, FLAG_FUNCTION}, // sin
314  {(fn)rt_radsin, 0, 1, FLAG_FUNCTION}, // radsin
315  {(fn)rt_cos, 0, 1, FLAG_FUNCTION}, // cos
316  {(fn)rt_radcos, 0, 1, FLAG_FUNCTION}, // radcos
317  {(fn)rt_arctan, 0, 1, FLAG_FUNCTION | FLAG_MAY_HAVE_EXTRA_ARG}, // arctan
318  {(fn)rt_radarctan, 0, 1, FLAG_FUNCTION | FLAG_MAY_HAVE_EXTRA_ARG}, // radarctan
319  // {(fn)rt_arctanxy, 0, 2, FLAG_FUNCTION}, // arctanxy
320  // {(fn)rt_radarctanxy, 0, 2, FLAG_FUNCTION}, // radarctanxy
321 
322  // sequences and random numbers
323  {(fn)rt_iseq, 0, 2, FLAG_FUNCTION}, // iseq
324  {(fn)rt_rseq, 0, 3, FLAG_FUNCTION}, // rseq
325  {(fn)rt_random, 0, 1, FLAG_FUNCTION | FLAG_MAY_HAVE_EXTRA_ARG}, // random
326  {(fn)rt_random, 0, 1, FLAG_FUNCTION | FLAG_MAY_HAVE_EXTRA_ARG}, // random
327  {(fn)rt_rerandom, 0, 0, FLAG_COMMAND | FLAG_MAY_HAVE_EXTRA_ARG}, // rerandom
328  {(fn)rt_rerandom, 0, 0, FLAG_COMMAND | FLAG_MAY_HAVE_EXTRA_ARG}, // rerandom
329  {(fn)rt_pick, 0, 1, FLAG_FUNCTION }, // pick
330 
331  // bit operations
332  {(fn)rt_lshift, 0, 2, FLAG_FUNCTION}, // lshift
333  {(fn)rt_ashift, 0, 2, FLAG_FUNCTION}, // ashift
334  {(fn)rt_bitand, 0, 2, FLAG_FUNCTION | FLAG_INFINITE_ARGS}, // bitand
335  {(fn)rt_bitor, 0, 2, FLAG_FUNCTION | FLAG_INFINITE_ARGS}, // bitor
336  {(fn)rt_bitxor, 0, 2, FLAG_FUNCTION | FLAG_INFINITE_ARGS}, // bitxor
337  {(fn)rt_bitnot, 0, 1, FLAG_FUNCTION }, // bitnot
338 
339  // transmitter commands
346  {(fn)rt_form, 0, 3, FLAG_FUNCTION}, // form
347  {(fn)rt_format, 0, 2, FLAG_FUNCTION}, // format
348  {(fn)rt_formattime, 0, 2, FLAG_FUNCTION}, // formattime
349  {(fn)rt_timezone, 0, 0, FLAG_FUNCTION}, // timezone
350 
351  // primitive commands
353  {(fn)rt_if, 0, 3, FLAG_FUNCTION | FLAG_COMMAND | FLAG_PROCESS_ARGS}, // ifelse
354  {(fn)rt_repeat, 0, 2, FLAG_COMMAND | FLAG_PROCESS_ARGS}, // repeat
355  {(fn)rt_repeat, 0, 2, FLAG_COMMAND | FLAG_PROCESS_ARGS}, // repeat
356  {(fn)rt_repcount, 0, 0, FLAG_FUNCTION | FLAG_PUSH_FRAME}, // repcount
357  {(fn)rt_while, 0, 2, FLAG_COMMAND | FLAG_PROCESS_ARGS}, // while
358  {(fn)rt_dowhile, 0, 2, FLAG_COMMAND | FLAG_PROCESS_ARGS}, // do.while
359  {(fn)rt_until, 0, 2, FLAG_COMMAND | FLAG_PROCESS_ARGS}, // until
360  {(fn)rt_dountil, 0, 2, FLAG_COMMAND | FLAG_PROCESS_ARGS}, // do.until
362  {(fn)rt_forever, 0, 1, FLAG_COMMAND | FLAG_PROCESS_ARGS}, // forever
363  {(fn)rt_ignore, 0, 1, FLAG_COMMAND}, // ignore
364  {(fn)rt_stop, 0, 0, FLAG_COMMAND}, // stop
365  {(fn)rt_stop, 0, 0, FLAG_COMMAND}, // stop
367  {(fn)rt_name, 0, 2, FLAG_COMMAND | FLAG_PUSH_PARENT}, // name
368  {(fn)rt_output, 0, 1, FLAG_COMMAND}, // output
369  {(fn)rt_output, 0, 1, FLAG_COMMAND}, // op
370  {(fn)rt_maybeoutput,0, 1, FLAG_COMMAND}, // maybeoutput
372  {(fn)rt_thing, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // thing
373  {(fn)rt_bye, 0, 0, FLAG_COMMAND}, // bye
374  {(fn)rt_wait, 0, 1, FLAG_COMMAND}, // wait
375  {(fn)rt_tag, 0, 1, FLAG_COMMAND}, // tag
376  {(fn)rt_goto, 0, 1, FLAG_COMMAND | FLAG_PUSH_PARENT}, // goto
377  {(fn)rt_definedp, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // defined?
378  {(fn)rt_definedp, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // definedp
379  {(fn)rt_primitivep, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // primitive?
380  {(fn)rt_primitivep, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // primitivep
381  {(fn)rt_namep, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // name?
382  {(fn)rt_namep, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // namep
383  {(fn)rt_procedurep, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // procedure?
384  {(fn)rt_procedurep, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // procedurep
386  {NULL, 0, 2, FLAG_COMMAND}, // case
387  {NULL, 0, 1, FLAG_COMMAND}, // cond
388  {(fn)rt_text, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // text
389  {(fn)rt_fulltext, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // fulltext
390  {(fn)rt_define, 0, 2, FLAG_COMMAND | FLAG_PUSH_PARENT}, // define
391  {(fn)rt_define, 0, 2, FLAG_COMMAND | FLAG_PUSH_PARENT}, // define
392  {(fn)rt_load, 0, 1, FLAG_COMMAND | FLAG_PUSH_PARENT | FLAG_PUSH_MODE}, // load
393  {(fn)rt_commandline,0, 0, FLAG_FUNCTION }, // commandline
394 
395  // misc
396  {NULL, 0, 0, FLAG_VARIABLE | FLAG_EX_PRINTDEPTHLIMIT}, // printdepthlimit
397  {NULL, 0, 0, FLAG_VARIABLE | FLAG_EX_PRINTWIDTHLIMIT}, // printwidthlimit
398  {NULL, 0, 0, FLAG_VARIABLE | FLAG_EX_FULLPRINTP}, // fullprintp
399  {NULL, 0, 0, FLAG_VARIABLE | FLAG_EX_CASEIGNOREDP}, // caseignoredp
400  {NULL, 0, 0, FLAG_VARIABLE | FLAG_EX_LOGOPLATFORM}, // logoplatform
401  {NULL, 0, 0, FLAG_VARIABLE | FLAG_EX_LOGOVERSION}, // logoversion
402  {NULL, 0, 0, FLAG_VARIABLE | FLAG_EX_LOGODIALECT}, // logodialect
403 
404  // error handling
405  {(fn)rt_catch, 0, 2, FLAG_FUNCTION | FLAG_PROCESS_ARGS}, // catch
406  {(fn)rt_throw, 0, 1, FLAG_FUNCTION | FLAG_MAY_HAVE_EXTRA_ARG}, // throw
407  {(fn)rt_error, 0, 0, FLAG_FUNCTION}, // error
408 
409  {NULL, 0, 2, FLAG_COMMAND}, // apply
410 
411  {(fn)rt_test, 0, 1, FLAG_COMMAND | FLAG_PUSH_FRAME }, // test
412  {(fn)rt_iftrue, 0, 1, FLAG_COMMAND | FLAG_PROCESS_ARGS}, // iftrue
413  {(fn)rt_iftrue, 0, 1, FLAG_COMMAND | FLAG_PROCESS_ARGS}, // ift
414  {(fn)rt_iffalse, 0, 1, FLAG_COMMAND | FLAG_PROCESS_ARGS}, // iffalse
415  {(fn)rt_iffalse, 0, 1, FLAG_COMMAND | FLAG_PROCESS_ARGS}, // iff
416 
417  {(fn)rt_backslashedp, 0, 1, FLAG_FUNCTION}, // backslashed?
418  {(fn)rt_backslashedp, 0, 1, FLAG_FUNCTION}, // backslashedp
419 
420  {(fn)rt_remdup, 0, 1, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // remdup
421  {(fn)rt_remove, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // remove
422  {(fn)rt_reverse, 0, 1, FLAG_FUNCTION}, // reverse
423  {(fn)rt_rawascii, 0, 1, FLAG_FUNCTION}, // rawascii
424  {(fn)rt_substringp, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // substring?
425  {(fn)rt_substringp, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // substringp
426  {(fn)rt_substring, 0, 2, FLAG_FUNCTION | FLAG_EQUAL_VARS}, // substring
427  {(fn)rt_gensym, 0, 0, FLAG_FUNCTION}, // gensym
428  {(fn)rt_combine, 0, 2, FLAG_FUNCTION}, // combine
429  {(fn)rt_quoted, 0, 1, FLAG_FUNCTION}, // quoted
430 
431  {(fn)rt_runresult, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // runresult
432  {(fn)rt_runmacro, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT | FLAG_PUSH_MODE}, // runmacro
433 
434  // internal access
435  {(fn)rt_libload, 0, 1, FLAG_FUNCTION}, // libload
436  {(fn)rt_libfree, 0, 1, FLAG_COMMAND}, // libfree
437  {(fn)rt_blocksize, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // packsize
438  {(fn)rt_listtoblock, 0, 2, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // listtoblock
439  {(fn)rt_blocktolist, 0, 2, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // blocktolist
440  {(fn)rt_dataaddr, 0, 1, FLAG_FUNCTION}, // dataaddr
441  {(fn)rt_listintoblock, 0, 3, FLAG_COMMAND | FLAG_PUSH_PARENT}, // listintoblock
442  {(fn)rt_funcaddr, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // funcaddr
443  {(fn)rt_openfile, 0, 2, FLAG_FUNCTION | FLAG_PUSH_MODE}, // openfile
444  {(fn)rt_closefile, 0, 1, FLAG_COMMAND}, // closefile
445  {(fn)rt_readblock, 0, 1, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // readblock
446  {(fn)rt_readinblock, 0, 1, FLAG_FUNCTION | FLAG_PUSH_MODE}, // readinblock
447  {(fn)rt_writeblock, 0, 1, FLAG_COMMAND}, // writeblock
448  {(fn)rt_external, 0, 3, FLAG_COMMAND | FLAG_PUSH_PARENT}, // external
449  {(fn)rt_internal, 0, 2, FLAG_COMMAND | FLAG_PUSH_PARENT}, // internal
450  {(fn)rt_int3, 0, 0, FLAG_COMMAND}, // _int3
451  {(fn)rt_stackframe, 0, 2, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // _stackframe
452  {(fn)rt_stackframeatom, 0, 2, FLAG_FUNCTION | FLAG_PUSH_PARENT}, // _stackframeatom
453 
454  // text i/o
455  {(fn)rt_readchar, 0, 0, FLAG_FUNCTION}, // readchar
456  {(fn)rt_readchar, 0, 0, FLAG_FUNCTION}, // rc
457  {(fn)rt_readchars, 0, 1, FLAG_FUNCTION}, // readchars
458  {(fn)rt_readchars, 0, 1, FLAG_FUNCTION}, // rcs
459  {(fn)rt_readrawline, 0, 0, FLAG_FUNCTION}, // readrawline
460  {(fn)rt_readword, 0, 0, FLAG_FUNCTION}, // readword
461  {(fn)rt_readword, 0, 0, FLAG_FUNCTION}, // rw
462  {(fn)rt_readlist, 0, 0, FLAG_FUNCTION}, // readlist
463  {(fn)rt_readlist, 0, 0, FLAG_FUNCTION}, // rl
464 
465  // environment
466  {(fn)rt_getenv, 0, 1, FLAG_FUNCTION}, // getenv
467  {(fn)rt_getenvs, 0, 0, FLAG_FUNCTION}, // getenvs
468  {(fn)rt_eofp, 0, 0, FLAG_FUNCTION}, // eof?
469  {(fn)rt_eofp, 0, 0, FLAG_FUNCTION}, // eofp
470 
471  // files and folders
472  {(fn)rt_currentfolder, 0, 0, FLAG_FUNCTION}, // currentfolder
473  {(fn)rt_makefolder, 0, 1, FLAG_COMMAND}, // makefolder
474  {(fn)rt_erasefolder, 0, 1, FLAG_COMMAND}, // erasefolder
475  {(fn)rt_folderp, 0, 1, FLAG_FUNCTION}, // folder?
476  {(fn)rt_folderp, 0, 1, FLAG_FUNCTION}, // folderp
477  {(fn)rt_renamefolder, 0, 2, FLAG_COMMAND}, // renamefolder
478  {(fn)rt_folders, 0, 1, FLAG_FUNCTION}, // folders
479  {(fn)rt_changefolder, 0, 1, FLAG_COMMAND}, // changefolder
480  {(fn)rt_files, 0, 1, FLAG_FUNCTION}, // files
481  {(fn)rt_erasefile, 0, 1, FLAG_COMMAND}, // erasefile
482  {(fn)rt_erasefile, 0, 1, FLAG_COMMAND}, // erf
483  {(fn)rt_filep, 0, 1, FLAG_FUNCTION}, // file?
484  {(fn)rt_filep, 0, 1, FLAG_FUNCTION}, // filep
485  {(fn)rt_renamefile, 0, 2, FLAG_COMMAND}, // renamefile
486  {(fn)rt_filesize, 0, 1, FLAG_FUNCTION}, // filesize
487  {(fn)rt_filetimes, 0, 1, FLAG_FUNCTION}, // filetimes
488  {(fn)rt_openread, 0, 1, FLAG_FUNCTION | FLAG_PUSH_MODE}, // openread
489  {(fn)rt_openwrite, 0, 1, FLAG_FUNCTION | FLAG_PUSH_MODE}, // openwrite
490  {(fn)rt_openappend, 0, 1, FLAG_FUNCTION | FLAG_PUSH_MODE}, // openappend
491  {(fn)rt_openupdate, 0, 1, FLAG_FUNCTION | FLAG_PUSH_MODE}, // openupdate
492  {(fn)rt_setread, 0, 1, FLAG_COMMAND}, // setread
493  {(fn)rt_setwrite, 0, 1, FLAG_COMMAND}, // setwrite
494  {(fn)rt_reader, 0, 0, FLAG_FUNCTION}, // reader
495  {(fn)rt_writer, 0, 0, FLAG_FUNCTION}, // writer
496  {(fn)rt_allopen, 0, 0, FLAG_FUNCTION}, // allopen
497  {(fn)rt_closeall, 0, 0, FLAG_COMMAND}, // closeall
498  {(fn)rt_readpos, 0, 0, FLAG_FUNCTION}, // readpos
499  {(fn)rt_setreadpos, 0, 1, FLAG_COMMAND}, // setreadpos
500  {(fn)rt_writepos, 0, 0, FLAG_FUNCTION}, // writepos
501  {(fn)rt_setwritepos, 0, 1, FLAG_COMMAND}, // setwritepos
502  {(fn)rt_dribble, 0, 1, FLAG_COMMAND}, // dribble
503  {(fn)rt_nodribble, 0, 0, FLAG_COMMAND}, // nodribble
504 
505 
506  {NULL, -1,-1, -1}
507  };
508 
509 
510 
511 
512 //===================================================
519 // GLOBALS_VAR_NAME. Then the primitives are created
524 //===================================================
525 void init_vars( )
526 {
527  #ifdef DEBUG_VAR
528  printf("<VAR> Vars initialized\n");
529  #endif //DEBUG_VAR
530 
531  // create the root variable
532  atom_t name = new_word( ROOT_VAR_NAME, -1 );
533  root = new_var( name, 0, 0 );
534  need_descr2( root );
535  SET_FLAGS( root, FLAG_FUNCTION );
536  LARGS( root ) = 0;
537  RARGS( root ) = 0;
538  LEVEL( root ) = 0;
539  PRIORITY( root ) = PRIORITY_CMD;
540  DEUSE( name );
541 
542  // create the globals variable
543  name = new_word( GLOBALS_VAR_NAME, -1 );
544  globals = new_var( name, 0, 0 );
545  SET_FLAGS( globals, FLAG_VARIABLE );
546  LARGS( root ) = 0;
547  RARGS( root ) = 0;
548  LEVEL( root ) = 0;
549  PRIORITY( root ) = PRIORITY_CMD;
550  DEUSE( name );
551 
552  unbound = new_integer( 0 );
553  stopped = new_integer( 1 );
554 
555  repeat_chain = new_list( new_integer(0), empty_list );
556  REPCOUNT( CAR(repeat_chain) ) = -1;
557 
558  last_error = empty_list;
559  delayed_free = empty_list;
560 
561  atom_t names = new_word( TR_PRIMITIVES, UNKNOWN );
562  atom_t tokens = tokenize( names, TOKENIZE_DATA );
563 
564  // setting TO, END and other words
565  atom_t t = tokens;
566  false_true[0] = USE(CAR(t)); t = CDR(t);
567  false_true[1] = USE(CAR(t)); t = CDR(t);
568  word_to = USE(CAR(t)); t = CDR(t);
569  word_to_syn = USE(CAR(t)); t = CDR(t);
570  word_end = USE(CAR(t)); t = CDR(t);
571  word_toplevel = USE(CAR(t)); t = CDR(t);
572  word_system = USE(CAR(t)); t = CDR(t);
573  word_error = USE(CAR(t)); t = CDR(t);
574  //word_run -- set in the next FOR-cycle
575 
576  // create primitives
577  int i;
578  for( i = 0; vars[i].largs>=0; i++, t=CDR(t) )
579  {
580  #ifdef SAFEMODE
581  assert( IS_NOT_EMPTY(t) ); // too few words in TR_PRIMITIVES
582  #endif
583 
584  //printf("%d ",i); dumpln(CAR(t));
585  atom_t name = CAR(t);
586  if( LENGTH(name) )
587  {
588  atom_t var = new_var( name, globals, 1 );
589  ADDRESS( var ) = (int_t)vars[i].function;
590  LEVEL( var ) = 1;
591  LARGS( var ) = vars[i].largs;
592  RARGS( var ) = vars[i].rargs;
593 
594  if( vars[i].flags & FLAG_PRIORITY_MUL )
595  PRIORITY( var ) = PRIORITY_MUL;
596  else if( vars[i].flags & FLAG_PRIORITY_ADD )
597  PRIORITY( var ) = PRIORITY_ADD;
598  else if( vars[i].flags & FLAG_PRIORITY_LOG )
599  PRIORITY( var ) = PRIORITY_LOG;
600  else if( vars[i].flags & FLAG_PRIORITY_CMP )
601  PRIORITY( var ) = PRIORITY_CMP;
602  else if( vars[i].flags & FLAG_COMMAND )
603  PRIORITY( var ) = PRIORITY_CMD;
604  else
605  PRIORITY( var ) = PRIORITY_FUN;
606 
607  SET_FLAGS( var, (vars[i].flags&ALL_VAR_FLAGS) | FLAG_PRIMITIVE );
608 
609  // initialize system variables to (unbound)
610  if( IS_VARIABLE(var) )
611  {
612  if( vars[i].flags & FLAG_EX_PRINTDEPTHLIMIT ) printdepthlimit = var;
613  if( vars[i].flags & FLAG_EX_PRINTWIDTHLIMIT ) printwidthlimit = var;
614  if( vars[i].flags & FLAG_EX_FULLPRINTP ) fullprintp = var;
615  if( vars[i].flags & FLAG_EX_CASEIGNOREDP ) caseignoredp = var;
616 
617  if( vars[i].flags & FLAG_EX_LOGOPLATFORM )
618  VALUE(var) = new_word(LOGO_PLATFORM,-1);
619  else if( vars[i].flags & FLAG_EX_LOGOVERSION )
620  VALUE(var) = new_word(LOGO_VERSION,-1);
621  else if( vars[i].flags & FLAG_EX_LOGODIALECT )
622  VALUE(var) = new_word(LOGO_DIALECT,-1);
623  else
624  VALUE(var) = USE( unbound );
625 
626  VARTYPE(var) = VAR_TYPE_RUNTIME; // value is in var's atom
627  }
628 
629  //printf("{%d",REF(word_run));
630  if( ADDRESS(var) == (int_t)rt_run ) word_run = USE(name);
631  if( ADDRESS(var) == (int_t)rt_make ) word_make = USE(name);
632  if( ADDRESS(var) == (int_t)rt_plus ) word_plus = USE(name);
633  //printf("%d}\n",REF(word_run));
634  }
635  }
636 
637  #ifdef SAFEMODE
638  assert( IS_EMPTY(t) ); // too many words in TR_PRIMITIVES
639  #endif
640 
641  DEUSE( names );
642  DEUSE( tokens );
643 }
644 
645 
646 
647 
648 //===================================================
660 //===================================================
661 void finit_vars( )
662 {
663  DEUSE( globals );
664  DEUSE( root );
665  DEUSE( repeat_chain );
666 
667  if( REF(last_error)>1 ) REF(last_error)=1; // patch
668 
669 #ifdef SAFEMODE
670  //printf( "REF(unbound)=%d\n",REF(unbound) );
671  //printf( "REF(false_true[0])=%d\n",REF(false_true[0]) );
672  //printf( "REF(last_error=%x)=%d\n",(int)last_error,REF(last_error) );
673  //printf( "REF(word_run=%x)=%d\n",(int)word_run,REF(word_run) );
674  assert( REF(unbound)==1 );
675  assert( REF(stopped)==1 );
676  assert( REF(word_error)==1 );
677  assert( REF(word_system)==1 );
678  assert( REF(word_toplevel)==1 );
679  assert( REF(word_to)==1 );
680  assert( REF(word_to_syn)==1 );
681  assert( REF(word_end)==1 );
682  assert( REF(false_true[0])==1 );
683  assert( REF(false_true[1])==1 );
684  assert( REF(word_run)==1 );
685  assert( REF(word_make)==1 );
686  assert( REF(word_plus)==1 );
687  assert( REF(last_error)==1 );
688 #endif
689 
690  // IMPORTANT! The unbound atom is considered
691  // not use-able amd deuse-able, thus its reference
692  // count is always 1. Because of this DEUSE will
693  // not automatically delete it, thus we delete is
694  // manually and adjust statistics manually.
695  DEUSE( unbound );
696  DEUSE( stopped );
697 
698  #ifdef ADVANCED
699  stats[ID(unbound)].deallocs++;
700  stats_free++;
701  stats[ID(stopped)].deallocs++;
702  stats_free++;
703  #endif //ADVANCED
704  delete_numeric( unbound ); // special case
705  delete_numeric( stopped ); // special case
706  DEUSE( word_error );
707  DEUSE( word_system );
708  DEUSE( word_toplevel );
709  DEUSE( word_to );
710  DEUSE( word_to_syn );
711  DEUSE( word_end );
712  DEUSE( false_true[0] );
713  DEUSE( false_true[1] );
714  DEUSE( last_error );
715  DEUSE( delayed_free );
716  DEUSE( word_run );
717  DEUSE( word_make );
718  DEUSE( word_plus );
719 
720  #ifdef DEBUG_VAR
721  printf("<VAR> Vars finalized\n");
722  #endif //DEBUG_VAR
723 }
724 
725 
726 
727 
728 //===================================================
749 //===================================================
750 atom_t new_var( atom_t name, atom_t parent, int attach )
751 {
752  #ifdef SAFEMODE
753  assert( name );
754  assert( IS_WORD(name)||IS_SUBWORD(name)||IS_EMPTY(name) );
755  assert( !parent||IS_VARATOM(parent) );
756  #endif
757 
760  DESCR2(a) = 0;
761 
762  REF(a) = 1;
763  ID(a) = VAR_ID;
764 
765  NAME(a) = USE(name);
766  FLAGS(a) = 0;
767  PARENT(a) = parent; // weak link, no ref++
769  if( parent )
770  {
771  need_descr2( parent );
772  if( attach ) LOCALS(parent) = new_list( a, LOCALS(parent) );
773  LEVEL(a) = LEVEL(parent)+1;
774  OFFSET(a) = 0;
775  }
776  else
777  LEVEL(a) = 0;
778 
779  #ifdef DEBUG_ATOM
780  printf("<ATOM> [%08x] var="STR"\n",(int)a,STRING(name));
781  #endif //DEBUG_ATOM
782 
783  #ifdef ADVANCED
784  stats[ID(a)].allocs+=2; // it's 2 because of
785  stats_free-=2; // the 1st descriptor
786  if( stats[ID(a)].max<(stats[ID(a)].allocs-stats[ID(a)].deallocs) )
787  stats[ID(a)].max=(stats[ID(a)].allocs-stats[ID(a)].deallocs);
788  #endif //ADVANCED
789 
790 
791  #ifdef DEBUG_RUNTIME_ATOMS
793  {
794  outter( TEXT("<RUNTIME> new "), -1 );
795  dump_atom_address( a );
796  dump_atom( a, 1 );
797  outter( TEXT("\n"), -1 );
798  }
799  #endif
800  #ifdef DEBUG_COMPILETIME_ATOMS
801  if( compiling_code )
802  {
803  outter( TEXT("<COMPILETIME> new "), -1 );
804  dump_atom_address( a );
805  dump_atom( a, 1 );
806  outter( TEXT("\n"), -1 );
807  }
808  #endif
809 
810  return a;
811 }
812 
813 
814 
815 
816 //===================================================
825 //===================================================
826 int need_descr2( atom_t var )
827 {
828  // create descr2 if it does not exist
829  if( DESCR2(var) ) return 0;
830  DESCR2(var) = take_from_pool( &data_pool );
831 
832  // initialize descr2
833  atom_t def = empty_list;
834  def = new_list( empty_list, def ); // TREE
835  def = new_list( empty_list, def ); // BODY
836  def = new_list( empty_list, def ); // SOURCE
837  def = new_list( empty_list, def ); // FULLSOURCE
838  DEFINITIONS(var) = def;
839  LOCALS(var) = empty_list;
840  BINARY(var) = empty_list;
841 
842  #ifdef ADVANCED
843  stats[ID(var)].allocs++;
844  if( stats[ID(var)].max<(stats[ID(var)].allocs-stats[ID(var)].deallocs) )
845  stats[ID(var)].max=(stats[ID(var)].allocs-stats[ID(var)].deallocs);
846  stats_free--;
847  #endif //ADVANCED
848 
849  return 1;
850 }
851 
852 
853 
854 
855 //===================================================
863 //===================================================
865 {
866  //printf(">>>DELETEVAR "); dumpln(NAME(a));
867  //if( DESCR2(a) ) { printf(">>> DEFINITIONS "); dump_atom(DEFINITIONS(a),1); printf("\n\n"); }
868 
869  // dereference value of primitive/global variables
870  if( (IS_PRIMITIVE(a) || IS_GLOBAL(a) || IS_TAG(a) || IS_RUNTIME(a)) && IS_VARIABLE(a) )
871  {
872  //printf(">>>DELETEVARVALUE "); dumpln(VALUE(a));
873  DEUSE( VALUE(a) );
874  }
875 
876  //if(a==root){printf(">>>DELETEVARNAME "); dumpln(NAME(a));}
877  DEUSE( NAME(a) );
878 
879  // descriptors have no reference counts
881  #ifdef ADVANCED
882  stats[ID(a)].deallocs++;
883  stats_free++;
884  #endif //ADVANCED
885 
886  if( DESCR2(a) )
887  {
888  //printf(">>>DELETEVARLOCALS\n");
889  //printf(">>>id=%d ref=%d\n",ID(a),REF(a));
890  //dumpln(LOCALS(a));
891  DEUSE( LOCALS(a) );
892  //no-DEUSE( BODY(a) );
893  //no-DEUSE( TREE(a) );
894  //printf(">>>DELETEVARBINARY\n");
895  DEUSE( BINARY(a) );
896  //no-DEUSE( SOURCE(a) );
897  //if( a==root )
898  //{
899  //printf(">>>DELETEVARDEFINITIONS\n");
900  //printf(">>>BODY OF ROOT ID=%d\n",ID(root));
901  //dumpln(BODY(root)); printf("========\n");
902  //printf(">>>ROOT FULLSOURCE="); dumpln(FULLSOURCE(a));
903  //printf(">>>ROOT SOURCE="); dumpln(SOURCE(a));
904  //printf(">>>ROOT BODY="); dumpln(BODY(a));
905  //printf(">>>ROOT TREE="); dumpln(TREE(a));
906  //}
907  //printf("vvvvvvvvvvvvvvvvvvvvvvvv\n");
908  DEUSE( DEFINITIONS(a) );
909  //printf("^^^^^^^^^^^^^^^^^^^^^^^^\n");
910  //if( a==root )
911  //{
912  //printf(">>>DONE\n");
913  //}
914  //printf(">>>DELETEVARDEFINITIONS2\n");
916 
917  #ifdef ADVANCED
918  stats[ID(a)].deallocs++;
919  stats_free++;
920  #endif //ADVANCED
921  }
922  return_to_pool( &data_pool, a );
923  //if(a==root) printf(">>> DONE!\n");
924 }
925 
926 
927 
928 
929 //===================================================
936 //===================================================
937 void dump_var( atom_t a, int level )
938 {
939 #ifdef ADVANCED
940  #define DUMP_BUF_SIZE 128
941  char_t buf[DUMP_BUF_SIZE];
942  int n;
943  int i;
944 
945  if( OPTION_USER_VARIABLES && IS_PRIMITIVE(a) ) return;
946 
947  // print required number of spaces
948  for( i=0; i<level; i++ ) outter( TEXT(" "), 3 );
949 
950  // print type, name and additional info
951  if( IS_PRIMITIVE(a) ) outter( TEXT("PRIM"), -1 );
952  if( IS_VARIABLE(a) ) outter( TEXT("VAR"), -1 );
953  if( IS_FUNCTION(a) ) outter( TEXT("FUN"), -1 );
954  if( IS_COMMAND(a) ) outter( TEXT("CMD"), -1 );
955 
956  if( IS_FUNCTION(a)||IS_COMMAND(a) )
957  {
958  n = SPRINTF( buf, DUMP_BUF_SIZE, TEXT("[%d"), LARGS(a) );
959  outter( buf, n );
960  n = SPRINTF( buf, DUMP_BUF_SIZE, TEXT(":%d]"), RARGS(a) );
961  outter( buf, n );
962  }
963 
964  outter( TEXT(" "), 1 );
965  outter( STRING(NAME(a)), LENGTH(NAME(a)) );
966  //if( !IS_PRIMITIVE(a) && (IS_FUNCTION(a)||IS_COMMAND(a)) )
967  //{
968  // outter( TEXT("="), 1 );
969  // dump( TREE(a) );
970  //}
971 
972  if( IS_VARIABLE(a) && a!=root && a!=globals )
973  if( IS_RUNTIME(a) )
974  {
975  outter( TEXT(" = "), 3 );
976  dump_atom( VALUE(a), 1 );
977  }
978 
979  outter( TEXT("\n"), 1 );
980 
981  if( DESCR2(a) )
982  {
983  atom_t locals = LOCALS(a);
984  for( ; IS_NOT_EMPTY(locals); locals=CDR(locals) )
985  dump_atom( CAR(locals), level+1 );
986  }
987 
988  #undef DUMP_BUF_SIZE
989 
990 #endif //ADVANCED
991 }
992 
993 
994 
995 
996 //===================================================
1014 //===================================================
1015 atom_t find_var( atom_t name, atom_t parent )
1016 {
1017 #ifdef SAFEMODE
1018  assert( IS_WORD(name) || IS_SUBWORD(name) );
1019  assert( parent );
1020  assert( IS_VARATOM(parent) );
1021 #endif
1022 
1023  #ifdef DEBUG_FIND_VAR
1024  printf("<FINDVAR> Search "); dumpln(name);
1025  printf("<FINDVAR> Current var tree "); dumpln(root);
1026  #endif
1027 
1028  // scan parent and its parents
1029  atom_t a;
1030  for( ; parent; parent=PARENT(parent) )
1031  {
1032  #ifdef DEBUG_FIND_VAR
1033  printf("<FINDVAR> Search it in parent "); dumpln(NAME(parent));
1034  #endif
1035  a = find_local_var( name, parent );
1036  #ifdef DEBUG_FIND_VAR
1037  if( a ) { printf("<FINDVAR> Found in "); dumpln(NAME(parent)); }
1038  #endif
1039  if( a ) return a;
1040  }
1041 
1042  #ifdef DEBUG_FIND_VAR
1043  printf("<FINDVAR> Search it in parent "); dumpln(NAME(globals));
1044  #endif
1045  a = find_local_var( name, globals );
1046  #ifdef DEBUG_FIND_VAR
1047  if( a ) { printf("<FINDVAR> Found in "); dumpln(NAME(globals)); }
1048  #endif
1049  if( a ) return a;
1050 
1051  #ifdef DEBUG_FIND_VAR
1052  printf("<FINDVAR> Not found\n");
1053  #endif
1054  return NULL; // not found
1055 }
1056 
1057 
1058 
1059 
1060 //===================================================
1073 //===================================================
1075 {
1076  atom_t parent;
1077  atom_t var;
1078 
1079  #ifdef SAFEMODE
1080  assert( IS_WORD(name) || IS_SUBWORD(name) );
1081  #endif
1082 
1083  #ifdef DEBUG_FIND_RUNTIME_VAR
1084  printf("<FIND_LOCAL_RUNTIME_VAR> Search "); dumpln(name);
1085  #endif
1086 
1087  // first scan variables created at run-time
1088  parent = *(atom_t*)(frame+BASE_OFFSET_LOCALS);
1089  var = find_local_var( name, parent );
1090  #ifdef DEBUG_FIND_RUNTIME_VAR
1091  if( var ) { printf("<FIND_LOCAL_RUNTIME_VAR> Found runtimer "); dumpln(NAME(var)); }
1092  #endif
1093  if( var ) return var;
1094 
1095  // then scan variables created at compile-time
1096  parent = *(atom_t*)(frame+BASE_OFFSET_PARENT);
1097  var = find_local_var( name, parent );
1098  #ifdef DEBUG_FIND_RUNTIME_VAR
1099  if( var ) { printf("<FIND_LOCAL_RUNTIME_VAR> Found local "); dumpln(NAME(var)); }
1100  #endif
1101  if( var ) return var;
1102 
1103  #ifdef DEBUG_FIND_RUNTIME_VAR
1104  printf("<FIND_LOCAL_RUNTIME_VAR> Not found\n");
1105  #endif
1106  return NULL; // not found
1107 }
1108 
1109 
1110 
1111 
1112 //===================================================
1132 //===================================================
1133 atom_t find_runtime_var( atom_t name, int frame )
1134 {
1135  atom_t parent;
1136  atom_t var;
1137 
1138  #ifdef SAFEMODE
1139  assert( IS_WORD(name) || IS_SUBWORD(name) );
1140  #endif
1141 
1142  #ifdef DEBUG_FIND_RUNTIME_VAR
1143  printf("<FIND_RUNTIME_VAR> Search "); dumpln(name);
1144  #endif
1145 
1146  // scan parent and its parents
1147  while( frame )
1148  {
1149  // first scan variables created at run-time
1150  parent = *(atom_t*)(frame+BASE_OFFSET_LOCALS);
1151  var = find_local_var( name, parent );
1152  #ifdef DEBUG_FIND_RUNTIME_VAR
1153  if( var ) { printf("<FIND_RUNTIME_VAR> Found runtimer "); dumpln(NAME(var)); }
1154  #endif
1155  if( var ) return var;
1156 
1157  // then scan variables created at compile-time
1158  parent = *(atom_t*)(frame+BASE_OFFSET_PARENT);
1159  var = find_local_var( name, parent );
1160  #ifdef DEBUG_FIND_RUNTIME_VAR
1161  if( var ) { printf("<FIND_RUNTIME_VAR> Found local "); dumpln(NAME(var)); }
1162  #endif
1163  if( var ) return var;
1164 
1165  // exit the loop if we reached the root variable
1166  if( parent==root ) break;
1167 
1168  // go to upper frame
1169  frame = *((int*)(frame));
1170  }
1171 
1172  // the variable is not found, thus now
1173  // scan the global variables
1174  var = find_local_var( name, globals );
1175  #ifdef DEBUG_FIND_RUNTIME_VAR
1176  if( var ) { printf("<FIND_RUNTIME_VAR> Found global "); dumpln(NAME(var)); }
1177  #endif
1178  if( var ) return var;
1179 
1180 
1181  #ifdef DEBUG_FIND_RUNTIME_VAR
1182  printf("<FIND_RUNTIME_VAR> Not found\n");
1183  #endif
1184  return NULL; // not found
1185 }
1186 
1187 
1188 
1189 
1190 //===================================================
1209 //===================================================
1211 {
1212 #ifdef SAFEMODE
1213  assert( IS_WORD(name) || IS_SUBWORD(name) );
1214  assert( parent );
1215  assert( IS_VARATOM(parent) || IS_LIST(parent) );
1216 #endif
1217 
1218  atom_t a;
1219 
1220  if( IS_LIST(parent) )
1221  {
1222  a = parent;
1223  }
1224  else
1225  {
1226  if( !DESCR2(parent) ) return NULL;
1227  a = LOCALS(parent);
1228  if( !a ) return NULL;
1229  }
1230 
1231  // scan all elements in the LOCALS
1232  for( ; IS_NOT_EMPTY(a); a=CDR(a) )
1233  if( same_words(name,NAME(CAR(a))) )
1234  {
1235  return CAR(a); // found
1236  }
1237 
1238  return NULL; // not found
1239 }
1240 
1241 
1242 //===================================================
1257 //===================================================
1258 atom_t new_local_var( atom_t name, atom_t function, int quoted )
1259 {
1260  #ifdef SAFE_MODE
1261  assert( IS_VAR(function) );
1262  assert( IS_ANY_WORD(name) );
1263  if( quoted )
1264  {
1265  assert( LENGTH(name)>1 );
1266  assert( *STRING(name)==TEXT(':') || *STRING(name)==TEXT('"') );
1267  }
1268  #endif
1269 
1270  atom_t real_name;
1271  if( quoted )
1272  real_name = new_subword( name, STRING(name)+1, LENGTH(name)-1 );
1273  else
1274  real_name = USE( name );
1275 
1276  if( find_local_var(real_name,function) )
1277  {
1278  //printf("THERE IS "); dump(real_name); printf(" IN FUNC "); dumpln(function);
1279  DEUSE( real_name );
1280  return new_error( ERROR_DUPLICATE_INPUT, name );
1281  }
1282 
1283  //printf("CREATED "); dump(real_name); printf(" IN FUNC "); dumpln(function);
1284  atom_t a = new_var( real_name, function, 1 );
1285  DEUSE( real_name );
1286  return a;
1287 }
1288 
1289 
1290 
1291 //===================================================
1314 //===================================================
1315 void copy_local_vars( int frame )
1316 {
1317  // get frame and var atom of the callee
1318  int callee_frame = frame;
1319  atom_t callee = *(atom_t*)(callee_frame+BASE_OFFSET_PARENT);
1320 
1321  // get frame and var atom of the caller
1322  int caller_frame = *(int*)(callee_frame+BASE_OFFSET_DYNAMIC);
1323  atom_t caller = *(atom_t*)(caller_frame+BASE_OFFSET_PARENT);;
1324 
1325  //printf( "}->callee = "); dumpln(NAME(callee));
1326  //printf( "}->caller = "); dumpln(NAME(caller));
1327 
1328 //#define FLAG_VARIABLE 0x0002
1329 //#define FLAG_FUNCTION 0x0004
1330 //#define FLAG_COMMAND 0x0008
1331 
1332 //#define VAR_TYPE_NORMAL 0x00 ///< variable value is in stack
1333 //#define VAR_TYPE_RUNTIME 0x01 ///< variable value is in the variable
1334 
1335  // Copies pure variable var from the callee to the caller.
1336  // If the variable exists in the caller, only its value
1337  // is transfered. If the variable does not exist, then
1338  // it is created as a runtime variable in the caller.
1339  // If to_atom is null, then there is no target variable
1340  void copy_var( atom_t from_var, atom_t to_var )
1341  {
1342  if( !to_var )
1343  {
1344  if( caller==root )
1345  {
1346  to_var = new_var( NAME(from_var), globals, 1 );
1347  }
1348  else
1349  {
1350  to_var = new_var( NAME(from_var), caller, 0 );
1351  atom_t* localsp = (atom_t*) (caller_frame + BASE_OFFSET_LOCALS);
1352  *localsp = new_list( to_var, *localsp ); // attach to other runtimers
1353  }
1354  VARTYPE( to_var ) = VAR_TYPE_RUNTIME;
1355  VALUE( to_var ) = USE( unbound );
1356  }
1357 
1358  //printf("copy "); dump_atom(NAME(PARENT(from_var)),1);
1359  //printf("."); dump_atom(NAME(from_var),1);
1360  //printf(" -> "); dump_atom(NAME(PARENT(to_var)),1);
1361  //printf("."); dump_atom(NAME(to_var),1);
1362 
1363  //printf("\n-->from_var=<|"); dump_atom((to_var),1);
1364  //printf("|>\n-->to_var=<|"); dump_atom((to_var),1);
1365  //printf("|>\n");
1366 
1367  // Continue with copying
1368  atom_t value;
1369 
1370  // get the value from the source variable variable
1371  SET_FLAGS( to_var, FLAG_VARIABLE );
1372  if( IS_NORMAL(from_var) )
1373  { // CASE 3: value is in the current stack
1374  value = *(atom_t*)((char*)callee_frame+OFFSET(from_var));
1375  }
1376  else
1377  { // CASE 4: value pointed by var's atom
1378  value = VALUE( from_var );
1379  }
1380 
1381  // put the value in the target variable
1382  if( IS_NORMAL(to_var) )
1383  {
1384  //printf("normal var\n");
1385  atom_t* varptr = (atom_t*) ((char*)caller_frame + OFFSET( to_var ));
1386  //printf(" old="); dump_atom(*varptr,1);
1387  DEUSE( *varptr );
1388  *varptr = USE( value );
1389  }
1390  else
1391  {
1392  //printf("runtime var %x %x\n",(unsigned int)to_var,(unsigned int)VALUE(to_var));
1393  //printf(" old="); dump_atom(VALUE(to_var),1);
1394  DEUSE( VALUE(to_var) );
1395  VALUE( to_var ) = USE(value);
1396  }
1397 
1398  //printf(" new="); dump_atom(value,1);
1399  //printf("\n");
1400  } //copy_var()
1401 
1402  // Copies function/command var from the callee to the caller.
1403  // If to_atom is null, then there is no target variable
1404  void copy_func( atom_t from_var, atom_t to_var )
1405  {
1406  // if target does not exist - attach the var to the target parent
1407  // decrease the level of all static locals and recompile
1408  if( !to_var )
1409  {
1410  to_var = USE( from_var );
1411  LOCALS( caller ) = new_list( to_var, LOCALS( caller ) );
1412  }
1413  else
1414  {
1415  // if definitions are incompatible (different number of
1416  // local parameters) then exit without copying
1417  if (LARGS( from_var ) != LARGS( to_var ) || RARGS( from_var ) != RARGS( to_var ))
1418  {
1419  return;
1420  }
1421 
1422  FLAGS( to_var ) = FLAGS( from_var );
1423  VARTYPE( to_var ) = VARTYPE( from_var );
1424  PRIORITY( to_var ) = PRIORITY( from_var );
1425  ADDRESS( to_var ) = ADDRESS( from_var );
1426 
1427  DEUSE( LOCALS( to_var ) );
1428  LOCALS( to_var ) = USE( LOCALS( from_var ) );
1429 
1430  DEUSE( DEFINITIONS( to_var ) );
1431  DEFINITIONS( to_var ) = USE( DEFINITIONS( from_var ) );
1432 
1433  DEUSE( BINARY( to_var ) );
1434  BINARY( to_var ) = USE( BINARY( from_var ) );
1435  }
1436  }
1437 
1438  void copy_var_or_func( atom_t from_var )
1439  {
1440  // primitives cannot be copied
1441  if( IS_PRIMITIVE(from_var) ) return;
1442 
1443  // not notmals and not runtimes cannot be copies
1444  if( !IS_NORMAL(from_var) && !IS_RUNTIME(from_var) ) return;
1445 
1446  // search the destination variable
1447  atom_t to_var = find_local_runtime_var( NAME(from_var), caller_frame );
1448 
1449  // destination var must be non-primitive and (normal or runtime)
1450  if( to_var )
1451  {
1452  if( IS_PRIMITIVE(to_var) ) return;
1453  if( !IS_NORMAL(to_var) && !IS_RUNTIME(to_var) ) return;
1454  }
1455 
1456  // if variable or function/command then copy the var
1457  if( IS_VARIABLE( from_var ) ) copy_var( from_var, to_var );
1458  if( IS_FUNCTION( from_var ) || IS_COMMAND( from_var ) ) copy_func( from_var, to_var );
1459 
1460  return;
1461  }
1462 
1463  atom_t vars;
1464 
1465  // first scan variables created at run-time
1466  vars = *(atom_t*)(callee_frame+BASE_OFFSET_LOCALS);
1467  for( ; IS_NOT_EMPTY(vars); vars=CDR(vars) ) copy_var_or_func( CAR(vars) );
1468 
1469  // then scan variables created at compile-time
1470  vars = LOCALS(callee);
1471  for( ; IS_NOT_EMPTY(vars); vars=CDR(vars) ) copy_var_or_func( CAR(vars) );
1472 }

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