Lhogho  0.0.028
 All Data Structures Files Functions Variables Typedefs Macros Pages
compiler.c
Go to the documentation of this file.
1 //
2 //
3 // Project: Lhogho
4 // File: compiler.c
5 //
6 // Copyright (C) 2007 P.Boytchev
7 //
8 // Revision history:
9 // 2007-06-11 - file created
10 // 2007-06-12 - added compile_to_file()
11 // - fixed bug #1735805 (No exec permission)
12 // 2007-06-13 - fixed bug #1736021 "Alloc/dealloc statistics"
13 // 2007-06-14 - fixed bug #1736041 "No docs for "compiler" module"
14 // - fixed bug #1736987 "No compile interface function"
15 // 2007-06-17 - fixed bug #1738571 "Invalid pointer in Ubuntu binary"
16 // 2007-06-19 - compile() renamed to compile_from_options()
17 // 2007-06-24 - fixed bug #1739110 (LOCAL :P creates local variable P)
18 // 2007-06-26 - fixed bug #1743510 print 2+1*(2+3)
19 // - fixed bug #1743443 print (1+2)*(3)
20 // 2007-06-30 - fixed bug #1745627 Option -Zm does not show memory (all Linuxes)
21 // - fixed bug #1743443 print (1+2)*(3)
22 // - fixed bug #1745920 print (3+[8 9]) causes crash
23 // 2007-07-05 - fixed bug #1748514 Memory leak in print (1+2)*(3-4)
24 // - fixed bug #1748520 Memory leak in print (1+"abc)*(3-4)
25 // 2007-07-29 - changed parameters of init_compiler()
26 // - compile_source() -> run_source()
27 // 2007-08-05 - running_compiled_code
28 // 2007-08-08 - Fixed bug #1769846 ':a' treated asword constant
29 // - Variable reference with column ':'
30 // - Support for MAKE when variable's name is word constant//
31 // 2007-08-09 - Fixed bug #1771163 Warning building the dev docs
32 // 2007-08-12 - Fixed bug #1767825 Bad return value for empty programs
33 // 2007-08-13 - Support for primitive variables
34 // - Fixed bug #1773113 MAKE does not work with primitive variables
35 // 2007-09-02 - Fixed bug #1786577 MAKE "A " -- error handling empty words
36 // 2007-09-16 - Fixed bug #1792210 print 1 2 does not generate error message
37 // 2007-09-18 - Support for OUTPUT, STOP
38 // 2007-09-23 - Support for IF
39 // 2007-09-29 - Support for REPEAT
40 // - Fixed big #1804776 Option -Zrt for IF command is ugly
41 // 2007-10-21 - Support for FOREVER
42 // 2007-11-03 - Fixed bug #1821536 repeat hangs
43 // 2007-11-04 - Fixed bug #1821549 Primitive redefinition
44 // - Support for WHILE, UNTIL
45 // 2007-11-06 - Support for DO.WHILE, DO.UNTIL
46 // 2007-11-09 - Fixed bug #1828216 MAKE with expression for var name
47 // - Fixed bug #1828215 MAKE does not work with unknown variables
48 // - Fixed bug #1828217 ':' does not work with unknown variables
49 // 2007-11-11 - Support for NAME
50 // 2007-11-18 - Fixed bug #1833928 Memory leak in CATCH-THROW
51 // 2007-11-19 - Fixed bug #1833020 Dual-functions not supported
52 // - Support for TAG, GOTO
53 // 2007-12-10 - compiling_code
54 // 2007-12-14 - Support for FULLTEXT
55 // 2008-01-07 - Fixed bug #1856864 Defined but unset variables
56 // - Support for RUNRESULT
57 // 2008-01-17 - Fixed bug #1872138 Crash when executing LOCAL "A 20
58 // 2008-01-23 - Fixed bug #1836433 Example with IFTRUE fails
59 // 2008-04-28 - Fixed bug #1953268 Wrong error position in bug1872138.lgo
60 // 2008-05-03 - Fixed bug #1953302 Crash if there is standalone word
61 // 2008-08-14 - Support for FOR
62 // 2009-08-02 - Fixed bug #2796155 Two local make problem with STOP
63 // - Fixed bug #2794985 CALHC fails with wrong input
64 // 2009-08-19 - Support for MAYBEOUTPUT
65 // 2009-08-29 - Fixed bug #2845099 Memory leak in THROW
66 // - Fixed bug #2845579 DEBUG_MEMORY_LEAKS finds two bad tests
67 // - Fixed bug #2846281 Errors not (de)used correctly
68 // - Fixed bug #2846574 Crash in empty CATCH
69 // - Fixed bug #2846131 Crash using RUN
70 // 2009-08-30 - Fixed bug #2847241 Crash in 2 THROWs in RUN
71 // 2009-08-31 - Fixed bug #2847389 Memory leak for unknown file
72 // 2010-06-25 - Added support for inner_eof
73 // 2010-06-26 - Fixed bug #3021703 DEBUGCOMPILE option crashes
74 // 2011-01-30 - Fixed bug #3167459 Inconsistency in numeric variable names
75 // 2011-03-01 - Fixed bug #3189884 Variable loaded from file can't be larger than 2046 chars
76 // 2011-03-03 - Fixed bug #3197053 DO.UNTIL behaves exactly like UNTIL
77 // - Fixed bug #3197052 DO.WHILE behaves exactly like WHILE
78 // 2011-10-13 - Support for Logo macros
79 // 2011-10-28 - Fixed bug #3427526 Indirect MAKE ("A) uses wrong name
80 // 2011-12-03 - Fixed bug #3442763 Parsing before run crash?
81 // 2012-01-02 - Command-line options are translatable
82 // 2012-01-09 - Support for multiple source file name extensions
83 // - Fixed bug #3471271 Cannot compile source with unknown extension in Linux
84 // 2012-02-06 - Fixed bug #3485028 File with shell script cannot be executed when compiled
85 // 2012-10-14 - Fixed bug #314 -x compile on Windows needs lhogho.exe next to .lgo source file
86 //
87 // This program is free software; you can redistribute it and/or modify
88 // it under the terms of the GNU General Public License as published by
89 // the Free Software Foundation; either version 2 of the License, or
90 // (at your option) any later version.
91 //
92 // This program is distributed in the hope that it will be useful,
93 // but WITHOUT ANY WARRANTY; without even the implied warranty of
94 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
95 // GNU General Public License for more details.
96 //
97 // You should have received a copy of the GNU General Public License
98 // along with this program; if not, write to the Free Software
99 // Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
100 //
101 
102 #undef __STRICT_ANSI__
103 
104 
105 #include <assert.h>
106 #include <stdio.h>
107 #include <stdlib.h>
108 #include <unistd.h> // getcwd()
109 #include <errno.h>
110 #include <wchar.h> // fwide()
111 #include <sys/stat.h> // stat()
112 #include <string.h>
113 #include <limits.h>
114 
115 #include "globals.h"
116 
117 #if defined(WINDOWS) || defined(LINUX)
118 #include <malloc.h>
119 #endif
120 
121 #include "atoms.h"
122 #include "vars.h"
123 #include "lists.h"
124 #include "words.h"
125 #include "numbers.h"
126 #include "parser.h"
127 #include "errors.h"
128 #include "mems.h"
129 #include "options.h"
130 #include "unicode.h"
131 #include "compiler.h"
132 #include "asm.h"
133 #include "runtime.h"
134 #include "translate.h"
135 
136 
137 
140 
141 char* source_extensions[] = { ".lgo", ".log", ".lg", ".logo", ".lho", ".lhogho" };
142 #define SRC_EXT_COUNT (sizeof source_extensions)/(sizeof source_extensions[0])
143 #define SRC_EXT (source_extensions[i])
144 
145 // forward definition
146 atom_t compile_expr( context_t* ctx, atom_t lisp, int mode );
147 atom_t compile_block( context_t* ctx, atom_t lisp, int mode );
148 atom_t compile_if( context_t* ctx, atom_t source, int mode );
149 atom_t compile_repeat( context_t* ctx, atom_t source );
150 atom_t compile_while( context_t* ctx, atom_t source, int is_while, int is_do );
151 atom_t compile_forever( context_t* ctx, atom_t source );
152 atom_t compile_catch( context_t* ctx, atom_t source, int mode );
153 atom_t compile_tag( context_t* ctx, atom_t source );
154 atom_t compile_goto( context_t* ctx, atom_t source, atom_t var );
155 atom_t compile_iftest( context_t* ctx, atom_t source, int criteria );
156 atom_t compile_for( context_t* ctx, atom_t source );
157 
158 
159 
160 //===================================================
168 //===================================================
170 {
171  //2011.02.09 Now output to console is always through UTF-8 (see lhogho.c)
172  //#ifdef UNICODE_CHARS
173  //fwide(stdout,1);
174  //#else
175  //fwide(stdout,-1);
176  //#endif
177 
179  compiling_code = 0;
180 
181  init_output( outter );
182  init_input( inner, inner_eof );
183  init_atoms();
184  init_parser();
185  init_vars();
186  init_runtime();
187  init_options( );
188  init_errors( );
189 
190  //printf("testing barrization\n");
191  //char_t i;
192  //printf("a->|a|\t|a|->a\n");
193  //for(i=0;i<128;i++) if( (i!=ENBAR(i)) || (i!=DEBAR(i)) )
194  // {
195  // if(i!=ENBAR(i))
196  // printf("%d->%d",i,ENBAR(i));
197  // else printf("\t");
198  //
199  // if(i!=DEBAR(i))
200  // printf("\t%d->%d",i,DEBAR(i));
201  // printf("\n");
202  // }
203 }
204 
205 
206 
207 
208 //===================================================
213 //===================================================
215 {
217  {
218  outter( TEXT("Variables:\n\0"), UNKNOWN );
219  dumpln( root );
220  //outter( TEXT("\n\0"), UNKNOWN );
221  }
223  finit_errors();
224  finit_runtime();
225  finit_vars();
226  finit_options();
227  finit_atoms();
228 }
229 
230 
231 
232 
233 //===================================================
241 //===================================================
243 {
244  //printf("enter compile()\n");
245  //printf("##### path=|%s|#######\n",getcwd (NULL,0));
246  //printf("enter compile()\n");
247  //printf("##### path=|%s|#######\n",getcwd (NULL,0));
248 
249  atom_t x;
250  atom_t sources = empty_list;
251 
252  // load comman-line source
254  {
256  if( IS_ERROR(x) )
257  {
258  dumpln(x);
259  return 1;
260  }
261  atom_t y = trim_shell_comment( x );
262  DEUSE( x );
263  sources = new_list( y, sources );
264  }
265 
266  // load embedded sources
267  int ptr;
268  unsigned char* code = load_file( option_compiler_filename_chars, &ptr );
269  if( !code )
270  {
272  dumpln( error );
273  return 0;
274  }
275 
276  // check for magic number
277  while( (*(int*)(code+ptr-4)==MAGIC_NUMBER) || (*(int*)(code+ptr-4)==MAGIC_COMPILER_NUMBER))
278  {
279  int size = *(int*)(code+ptr-8);
280  ptr -= size+8;
281  x = decode_word(code+ptr,size,0);
282  atom_t y = trim_shell_comment( x );
283  DEUSE( x );
284  sources = new_list( y, sources );
285  }
286 
287  DEALLOC( code );
288 
289  // if there is any source then read it and compile it
290  if( IS_EMPTY(sources) )
291  {
293  return 0;
294  }
295 
296  compiling_code = 1;
297  FULLSOURCE(root) = ( sources ); // already used once
298  SOURCE(root) = USE( sources );
300  if( IS_ERROR(x) )
301  {
302  dumpln(x);
303  //DEUSE(x);
305  compiling_code=0;
306  return 1;
307  }
308  compiling_code = 0;
309 
310 
311  // now the sources is confirmed to be compilable
312  // now check whether an executable file must be created
314  {
315  x = compile_to_file( );
316  if( IS_ERROR(x) ) { dumpln(x); DEUSE(x); return 1; }
317  }
318  return 0;
319 }
320 
321 
322 
323 // ===========================================================
339 // ===========================================================
340 
342 {
343  FILE* infile;
344  FILE* outfile;
345 
346  // compose the output name
347  char* output_filename;
348  chars_t output_filename_chars;
349 
350  {
351  // [1] use the original source name
352  // [2] remove trailing extension (as defined in source_extensions)
353  // if extension is different, do not remove anything
354  // [3] append the executable extension (as defined in EXE_EXT)
355  output_filename = (char*)ALLOC( strlen(option_source_filename)+strlen(EXE_EXT)+100 );
356  strcpy( output_filename, option_source_filename );
357 
358  char* extension = output_filename+strlen(output_filename);
359 
360  // remove any source extension
361  int i;
362  int done = 0;
363  for( i=0; i<SRC_EXT_COUNT; i++)
364  {
365  if( strcasecmp(extension-strlen(SRC_EXT),SRC_EXT)==0 )
366  {
367  strcpy( extension-strlen(SRC_EXT), EXE_EXT );
368  done = 1;
369  break;
370  }
371  }
372 
373  // add executable extension if not done already
374  if( !done )
375  {
376  #ifdef SAFEMODE
377  assert( strlen(EXE_EXT2)!=0 );
378  #endif
379 
380  if( strlen(EXE_EXT)==0 )
381  strcpy( extension, EXE_EXT2 );
382  else
383  strcpy( extension, EXE_EXT );
384  }
385 
386  output_filename_chars = UNFILENAME( output_filename );
387 
388  outfile = fopen( output_filename, "wb" );
389  if( errno ) return new_os_error( output_filename_chars );
390  }
391 
392  #define BUF_SIZE 1024
393  char* buffer[BUF_SIZE];
394  int size;
395 
396  // copy compiler into output file
397  infile = fopen( option_compiler_filename, "rb" );
398  if( errno ) return new_os_error( option_compiler_filename_chars );
399 
400  while( (size = fread( buffer, 1, BUF_SIZE, infile )) )
401  {
402  if( errno ) return new_os_error( option_compiler_filename_chars );
403 
404  fwrite( buffer, 1, size, outfile );
405  if( errno ) return new_os_error( output_filename_chars );
406  }
407  fclose( infile );
408  if( errno ) return new_os_error( option_compiler_filename_chars );
409 
410  // copy source into output file
411  int source_size = 0;
412  infile = fopen( option_source_filename, "rb" );
413  if( errno ) return new_os_error( option_source_filename_chars );
414 
415  while( (size = fread( buffer, 1, BUF_SIZE, infile )) )
416  {
417  if( errno ) return new_os_error( option_source_filename_chars );
418 
419  source_size += size;
420  fwrite( buffer, 1, size, outfile );
421  if( errno ) return new_os_error( output_filename_chars );
422  }
423  fclose( infile );
424  if( errno ) return new_os_error( option_source_filename_chars );
425 
426  // write source size
427  fwrite( &source_size, 1, 4, outfile );
428  if( errno ) return new_os_error( output_filename_chars );
429 
430  // write magic data
432  fwrite( &size, 1, 4, outfile );
433  if( errno ) return new_os_error( output_filename_chars );
434 
435  fclose( outfile );
436  if( errno ) return new_os_error( output_filename_chars );
437 
438  chmod( output_filename, S_IRWXU );
439  if( errno ) return new_os_error( output_filename_chars );
440 
441  DEALLOC( output_filename );
442 
443  return empty_list;
444 }
445 
446 
447 
448 
449 //===================================================
457 // ===========================================================
459 {
460  if( IS_EMPTY(data) ) return data;
461  if( IS_EMPTY(CAR(data)) ) return data;
462 
463  //printf("ensure "); dump_atom(data,1); printf("\n");
464  return data;
465 }
466 
467 
468 
469 
470 //===================================================
479 //===================================================
480 int run_function( atom_t function )
481 {
482  #ifdef SAFE_MODE
483  assert( ADDRESS(function) );
484  #endif
485 
486  typedef atom_t(*user_code_t)(); // Lhogho-compiled user code
487 
488  user_code_t func = (user_code_t)ADDRESS(function);
489 
490  //int x;
491  //printf("bin adr=%x\n",(int)func);
492  //for( x=0; x<128; x++ )
493  // {
494  // if( x % 16 ) printf(","); else printf("\n\tdb\t");
495  // printf("$%x", *(((unsigned char*)func)+x));
496  // }
497  //printf("\n");
498  //printf("start executing\n");
499 
500  //printf("******BEFORE******\n");
501  //dump_statistics();
502 
504  atom_t result = func();
506 
507  //printf("******AFTER******\n");
508  //dump_statistics();
509 
510  //printf("result=%x\n",(int)result);
511  //printf("ref=%d\n",REF(result));
512  //printf("result(ref=%d)=",REF(result)); dumpln(result);
513 
514  //printf("before error rootdef="); dump_atom(DEFINITIONS(root),1); printf("\n");
515  //printf("before error rootdef="); dump_atom(TREE(root),1); printf("\n");
516  if( IS_ERROR(result) )
517  {
518  int exit_code = 0;
519  if( ERRCODE(result)!= EXIT_BY_BYE &&
520  ERRCODE(result)!= EXIT_BY_THROW_TOPLEVEL &&
521  ERRCODE(result)!= EXIT_BY_THROW_SYSTEM )
522  {
523  dumpln( result );
524  exit_code = ERRCODE(result);
525  }
526  DEUSE(last_error);
529  return exit_code;
530  }
531  else
532  {
533  DEUSE( result );
534  return 0;
535  }
536 }
537 
538 
539 
540 
541 //===================================================
549 //===================================================
550 int run_source( chars_t source )
551 {
552  int exit_code;
553 
554  compiling_code = 1;
555  atom_t x = new_word( source, -1 );
556  atom_t y = trim_shell_comment( x );
557 
558  DEUSE( x );
559  DEUSE( BODY(root) ); BODY(root) = empty_list;
560  DEUSE( TREE(root) ); TREE(root) = empty_list;
564 
565  FULLSOURCE(root) = ( y ); // already used once
566  SOURCE(root) = USE( y );
568  if( IS_ERROR(x) )
569  {
570  exit_code = ERRCODE(x);
571  DEUSE( x );
572  compiling_code = 0;
573  }
574  else
575  {
576  compiling_code = 0;
577  exit_code = run_function(root);
578  //exit_code = 0;
579  }
580 
581  return exit_code;
582 }
583 
584 
585 
586 
587 //===================================================
607 //===================================================
608 atom_t compile_function( atom_t func, int mode, int is_macro )
609 {
610  #ifdef DEBUG_COMPILE
611  printf("<COMPILE> Compile "); dump(NAME(func));
612  if( mode==COMPILE_AS_PROC ) printf(" as procedure\n");
613  if( mode==COMPILE_AS_FUNC ) printf(" as function\n");
614  if( mode==COMPILE_AS_UNKNOWN ) printf(" as unknown\n");
615  #endif
616 
617  need_descr2( func );
618 
619  atom_t x;
620  atom_t y;
621  // if there is not syntax tree of the function
622  // then parse and treeify it first
623  if( IS_EMPTY(TREE(func)) )
624  {
625  y = build_syntax_tree( func );
626  if( IS_ERROR(y) ) return y;
627  }
628 
629  #ifdef DEBUG_COMPILE
630  printf("<COMPILE> Syntax tree built\n");
631  #endif
632 
633  context_t ctx;
634  ctx.size = 0;
635  ctx.generate = NULL;
636  ctx.parent = func;
637  ctx.exit_addr = 0;
638  //printf("SET0 ExAd=%d\n",ctx.exit_addr);
639 
640  // set offset of local variables
641  int offset = BASE_OFFSET_LOCALS-4; // this is the start offset
642  for( x = LOCALS(func); IS_NOT_EMPTY(x); x=CDR(x) )
643  if( IS_VARIABLE(CAR(x)) && OFFSET(CAR(x))==0 && IS_NORMAL(CAR(x)) )
644  {
645  //printf("set offset of "); dump(NAME(CAR(x)));
646  //printf(" to be %d\n",offset);
647  OFFSET(CAR(x)) = offset;
648  offset -= sizeof( atom_t );
649  }
650 
651  #ifdef DEBUG_COMPILE
652  printf("<COMPILE> Pass 1\n");
653  #endif
654 
655  //------------------------------
656  // calculate size of to-be-generated code
657  asm_prologue( &ctx, func, 1 );
658 
659  if( IS_EMPTY(TREE(func)) )
660  asm_empty_body( &ctx );
661  else
662  {
664  y = compile_block( &ctx, TREE(func), mode );
665  if( mode==COMPILE_AS_FUNC )
666  {
667  asm_output( &ctx, TREE(func), 0 ); // simulate OUTPUT
668  }
669  if( IS_ERROR(y) ) return y;
670  }
671  asm_preepilogue( &ctx );
672  ctx.exit_addr = ctx.size;
673  asm_epilogue( &ctx, func, is_macro );
674 
675  #ifdef DEBUG_COMPILE
676  printf("<COMPILE> Pass 1 done!\n");
677  printf("<COMPILE> Code size=%d\n\n",ctx.size);
678  printf("<COMPILE> Pass 2\n");
679  #endif
680 
681  //-----------------------------
682  // allocate memory for code
683  ctx.generate = new_mem( ctx.size );
684  ctx.size = 0;
685  //printf("old exit addr=%8x\n",ctx.exit_addr);
686  ctx.exit_addr = (int)MEMORY(ctx.generate)+ctx.exit_addr;
687  //printf("new base addr=%8x\n",(int)MEMORY(ctx.generate));
688  //printf("new exit addr=%8x\n",ctx.exit_addr);
689 
690 
691  //---------------------------------
692  // generate code for the body of the function
693  asm_prologue( &ctx, func, 1 );
694  if( IS_EMPTY(TREE(func)) )
695  asm_empty_body( &ctx );
696  else
697  {
698  y = compile_block( &ctx, TREE(func), mode );
699  if( mode==COMPILE_AS_FUNC ) asm_output( &ctx, TREE(func), 0 ); // simulate OUTPUT
700  if( IS_ERROR(y) )
701  {
702  DEUSE( ctx.generate );
703  return y;
704  }
705  }
706 
707  asm_preepilogue( &ctx );
708  asm_epilogue( &ctx, func, is_macro );
709 
710  #ifdef DEBUG_COMPILE
711  printf("<COMPILE> Pass 2 done!\n");
712  #endif
713 
714 
715  BINARY(func) = ctx.generate;
716  ADDRESS(func) = (int)MEMORY(BINARY(func));
717 
718  //dumpln( root );
719 
720  // generate code for local functions
721  for( x = LOCALS(func); IS_NOT_EMPTY(x); x=CDR(x) )
722  if( !IS_VARIABLE(CAR(x)) &&
723  !IS_PRIMITIVE(CAR(x)) &&
724  !IS_TAG(CAR(x)) )
725  {
727  if( IS_ERROR(y) ) return y;
728  }
729 
730  return empty_list;
731 }
732 
733 
734 
735 
736 //===================================================
743 //===================================================
745 {
746  #ifdef DEBUG_COMPILE
747  printf("<COMPILE> Re-compile external "); dump(NAME(func));
748  #endif
749 
750 #ifdef SAFE_MODE
751  assert( IS_EXTERNAL(func) );
752 #endif
753 
754  context_t ctx;
755  ctx.size = 0;
756  ctx.generate = NULL;
757  ctx.parent = func;
758  ctx.exit_addr = 0;
759 
760  #ifdef DEBUG_COMPILE
761  printf("<COMPILE> Pass 1\n");
762  #endif
763 
764  //------------------------------
765  // calculate size of to-be-generated code
766  asm_external_function( &ctx, func );
767 
768  //ctx.exit_addr = ctx.size;
769 
770  #ifdef DEBUG_COMPILE
771  printf("<COMPILE> Pass 1 done!\n");
772  printf("<COMPILE> Code size=%d\n\n",ctx.size);
773  printf("<COMPILE> Pass 2\n");
774  #endif
775 
776  //-----------------------------
777  // allocate memory for code
778  ctx.generate = new_mem( ctx.size );
779  ctx.size = 0;
780 
781 
782  //---------------------------------
783  // generate code for the body of the function
784  asm_external_function( &ctx, func );
785 
786  #ifdef DEBUG_COMPILE
787  printf("<COMPILE> Pass 2 done!\n");
788  #endif
789 
790 
791  DEUSE(BINARY(func));
792  BINARY(func) = ctx.generate;
793  ADDRESS(func) = (int)MEMORY(BINARY(func));
794 
795  return empty_list;
796 }
797 
798 
799 
800 
801 //===================================================
809 //===================================================
810 atom_t compile_internal_function( atom_t func, int static_link )
811 {
812  #ifdef DEBUG_COMPILE
813  printf("<COMPILE> Re-compile internal "); dump(NAME(func));
814  #endif
815 
816 #ifdef SAFE_MODE
817  assert( IS_INTERNAL(func) );
818 #endif
819 
820  context_t ctx;
821  ctx.size = 0;
822  ctx.generate = NULL;
823  ctx.parent = func;
824  ctx.exit_addr = 0;
825 
826  #ifdef DEBUG_COMPILE
827  printf("<COMPILE> Pass 1\n");
828  #endif
829 
830  //------------------------------
831  // calculate size of to-be-generated code
832  asm_internal_function( &ctx, static_link, func );
833 
834  //ctx.exit_addr = ctx.size;
835 
836  #ifdef DEBUG_COMPILE
837  printf("<COMPILE> Pass 1 done!\n");
838  printf("<COMPILE> Code size=%d\n\n",ctx.size);
839  printf("<COMPILE> Pass 2\n");
840  #endif
841 
842  //-----------------------------
843  // allocate memory for code
844  ctx.generate = new_mem( ctx.size );
845  ctx.size = 0;
846 
847 
848  //---------------------------------
849  // generate code for the body of the function
850  asm_internal_function( &ctx, static_link, func );
851  #ifdef DEBUG_COMPILE
852  printf("<COMPILE> Pass 2 done!\n");
853  #endif
854 
855 
856  // The address of the function should point to the
857  // newly created trampoline. The memory link should
858  // contain atoms that must be freed when the function
859  // is freed, namely:
860  // - the original memory atom
861  // - the new memory atom
862  // The old memoty atom is needed, because it points
863  // to the old code of the Lhogho function which is
864  // actually used by the new code.
865  BINARY(func) = new_list(ctx.generate,new_list(BINARY(func),empty_list));
866  ADDRESS(func) = (int)MEMORY(ctx.generate);
867 
868  return empty_list;
869 }
870 
871 
872 
873 
874 //===================================================
884 //===================================================
885 int is_constant ( atom_t lisp )
886 {
887  //printf("is_constant "); dump_atom(lisp,1); printf("\n");
888 
889  // empty list
890  if( IS_EMPTY(lisp) ) return 1;
891 
892  // number?
893  if( IS_INTEGER(lisp) ) return 1;
894  if( IS_FLOAT(lisp) ) return 1;
895 
896  // most non-expressions are constants
897  if( !IS_LIST(lisp) || !IS_EXPRESSION(lisp) )
898  {
899  if( IS_ANY_WORD(lisp)
900  && LENGTH(lisp)>1
901  && *STRING(lisp)==TEXT(':') )
902  {
903  return 0;
904  }
905  return 1;
906  }
907 
908  // if there are more than 1 items then it is not a constant
909  if( IS_NOT_EMPTY(CDR(lisp)) ) return 0;
910 
911  // so we have one element - it could be:
912  // constant - (2)
913  // non-constant - (pi)
914  atom_t elem = CAR(lisp);
915 
916  // (2)
917  if( IS_INTEGER(elem) ) return 1;
918 
919  // (2.5)
920  if( IS_FLOAT(elem) ) return 1;
921 
922  // ([2 5])
923  if( IS_LIST(elem) && !IS_EXPRESSION(elem) ) return 1;
924 
925  // (<not-word>), e.g. error, memory, var, ...
926  if( !IS_ANY_WORD(elem) ) return 0;
927 
928  // ("a)
929  if( LENGTH(elem)>1 && *STRING(elem)==TEXT('"') ) return 1;
930 
931  // (:a)
932  if( LENGTH(elem)>1 && *STRING(elem)==TEXT(':') ) return 0;
933 
934  // (number)
935  float64_t x;
936  if( atom_to_float( elem, &x ) ) return 1;
937 
938  // not a constant
939  return 0;
940 }
941 
942 
943 
944 
945 //===================================================
953 //===================================================
954 int is_reference ( atom_t lisp )
955 {
956  //printf("is reference="); dumpln(lisp);
957  // if a word starting with ":" then is a reference
958  if( IS_ANY_WORD(lisp)
959  && LENGTH(lisp)>1
960  && *STRING(lisp)==TEXT(':') )
961  {
962  //printf("it is reference\n");
963  return 1;
964  }
965 
966  // the only other reference is (:a)
967 
968  // non-expressions are not references
969  if( !IS_EXPRESSION(lisp) ) return 0;
970 
971  // empty lists are not references
972  if( IS_EMPTY(lisp) ) return 0;
973 
974  // if there are more than 1 items then it is not a reference
975  if( IS_NOT_EMPTY(CDR(lisp)) ) return 0;
976 
977  //printf("call recursive\n");
978  return is_reference( CAR(lisp) );
979 }
980 
981 
982 
983 
984 //===================================================
992 //===================================================
994 {
995  atom_t value = IS_LIST(lisp)&&IS_EXPRESSION(lisp)?CAR(lisp):lisp;
996  if( ctx->generate )
997  { // create ABC from "ABC if the constant is a word constant
998 
999  //printf("before = "); dumpln(lisp);
1000  if( IS_LIST(lisp) && IS_EXPRESSION(lisp) ) lisp = CAR( lisp ); //Fix for bug #3427526
1001  //printf("after = "); dumpln(lisp);
1002 
1003  if( IS_ANY_WORD( lisp )
1004  && LENGTH(lisp)>0
1005  && *STRING(lisp)==TEXT('"') )
1006  {
1007  value = new_subword( lisp, STRING(lisp)+1, LENGTH(lisp)-1 );
1008  ATOMS(ctx->generate) = new_list( value, ATOMS(ctx->generate) );
1009  }
1010  }
1011  asm_push_atom( ctx, value );
1012  return unbound;
1013 }
1014 
1015 
1016 
1017 
1018 //===================================================
1034 //===================================================
1035 atom_t compile_local( context_t* ctx, atom_t source, int* processed )
1036 {
1037  // remove all inputs which are constant words
1038  // because they are processed automatically
1039  atom_t a;
1040  atom_t b;
1041  for( a=source; IS_NOT_EMPTY(CDR(a)); ) // possibly infinite if atoms are broken
1042  {
1043  atom_t node = CAR(CDR(a));
1044  if( (!IS_ANY_WORD(node)) ||
1045  (LENGTH(node)==0) ||
1046  (*STRING(node)!=TEXT('"')) )
1047  {
1048  a = CDR(a);
1049  continue;
1050  }
1051  // get rid of the next element in the
1052  // list, because it is constant-word
1053  b = CDR(a);
1054  CDR(a) = CDR(b);
1055  CDR(b) = empty_list;
1056  DEUSE( b );
1057  }
1058  // check whether everything is removed
1059  // if yes, then no need to process LOCAL any more
1060  *processed = IS_EMPTY( CDR(source) );
1061  return unbound;
1062 }
1063 
1064 
1065 
1066 
1067 //===================================================
1087 //===================================================
1088 atom_t compile_make( context_t* ctx, atom_t source, int is_name, int* processed )
1089 {
1090  atom_t params = CDR(source);
1091  atom_t name;
1092  atom_t value_src;
1093  if( is_name )
1094  {
1095  name = CAR(CDR(params));
1096  value_src = params;
1097  }
1098  else
1099  {
1100  name = CAR(params);
1101  value_src = CDR(params);
1102  }
1103 
1104  //printf("value="); dumpln(value_src);
1105  *processed = 1;
1106 
1107  // Check the first input of MAKE. If it is a word constant
1108  // then we have immediate MAKE which is compiled directly.
1109  // Otherwise we have indirect MAKE.
1110 
1111  if( IS_ANY_WORD(name)
1112  && LENGTH(name)>1
1113  && *STRING(name)==TEXT('"') )
1114  {
1115  // We have direct MAKE - i.e. we know the name of the
1116  // variable which value is changed. Generate code which
1117  // will push the absolute address of the variable.
1118  atom_t real_name = new_subword( name, STRING(name)+1, LENGTH(name)-1 );
1119  atom_t var = find_var( real_name, ctx->parent );
1120  if( var )
1121  {
1122  //printf("found var "); dump_atom(NAME(var),1); printf(" parent="); dumpln(NAME(PARENT(var)));
1123  //printf("--- isglobal=%d isnormal=%d isruntime=%d\n",IS_GLOBAL(var),IS_NORMAL(var),IS_RUNTIME(var));
1124  if( !IS_VARIABLE( var ) )
1125  {
1126  DEUSE( real_name );
1127  return new_error( ERROR_NOT_A_VAR, name );
1128  }
1129  // direct make + existing variable
1130  // push <value>
1131  atom_t y = compile_expr( ctx, value_src, COMPILE_AS_FUNC );
1132  if( IS_ERROR(y) ) return y;
1133  asm_make_direct( ctx, var, source );
1134  }
1135  else
1136  {
1137  // direct make + NON-existing variable
1138  *processed = 0;
1139  }
1140  DEUSE( real_name );
1141  }
1142  else
1143  {
1144  // indirect make
1145  // leave handling for rt_make
1146  //printf("not found var\n");
1147  *processed = 0;
1148  }
1149 
1150  return unbound;
1151 }
1152 
1153 
1154 
1155 //===================================================
1163 //===================================================
1165 {
1166  atom_t params = CDR(source);
1167  atom_t value_src = params;
1168 
1169  atom_t result = compile_expr( ctx, value_src, COMPILE_AS_FUNC );
1170  asm_output( ctx, source, 1 ); // true output
1171 
1172  return result;
1173 }
1174 
1175 
1176 
1177 
1178 //===================================================
1186 //===================================================
1188 {
1189  atom_t params = CDR(source);
1190  atom_t value_src = params;
1191 
1192  atom_t result = compile_expr( ctx, value_src, COMPILE_AS_UNKNOWN );
1193  asm_push_result( ctx );
1194  asm_output( ctx, source, 1 ); // true output
1195 
1196  return result;
1197 }
1198 
1199 
1200 
1201 
1202 //===================================================
1210 //===================================================
1212 {
1213  asm_stop( ctx, source );
1214  return unbound;
1215 }
1216 
1217 
1218 
1219 
1220 //===================================================
1234 //===================================================
1235 atom_t compile_if( context_t* ctx, atom_t source, int mode )
1236 {
1237  atom_t params = CDR(source);
1238  atom_t condition_src = params;
1239  atom_t condition = CAR(params);
1240  atom_t then_lisp = instruction_list(CAR(CDR(params)));
1241  atom_t else_lisp = instruction_list(CAR(CDR(CDR(params))));
1242 
1243  int has_else = !IS_EMPTY(else_lisp);
1244 
1245  if( mode==COMPILE_AS_FUNC && !has_else )
1246  return( new_error( ERROR_MISSING_RIGHTS, source ) );
1247 
1248  int branch = 0;
1249  int ifend = 0;
1250 
1251  //printf("IF STATEMENT\n");
1252  //printf(" COND="); dumpln(condition);
1253  //printf(" THEN="); dumpln(then_lisp);
1254  //printf(" ELSE="); dumpln(else_lisp);
1255 
1256  // compile condition of IF
1257  atom_t y = compile_expr( ctx, condition_src, COMPILE_AS_FUNC );
1258  if( IS_ERROR(y) ) return y;
1259 
1260  // add checker for boolean value
1261  asm_boolean( ctx, condition );
1262  branch = asm_if_prologue( ctx );
1263 
1264  // compile THEN of IF
1265  asm_label( ctx, TEXT("$then") );
1266  y = compile_block( ctx, then_lisp, mode );
1267  if( IS_ERROR(y) ) return y;
1268  if( has_else )
1269  ifend = asm_if_epilogue( ctx );
1270  asm_fix( ctx, branch );
1271 
1272  // compile ELSE of IF
1273  asm_label( ctx, TEXT("$else") );
1274  if( has_else )
1275  {
1276  y = compile_block( ctx, else_lisp, mode );
1277  if( IS_ERROR(y) ) return y;
1278  asm_fix( ctx, ifend );
1279  asm_label( ctx, TEXT("$ifend") );
1280  }
1281 
1282  if( mode==COMPILE_AS_PROC )
1283  asm_adjust_result( ctx );
1284 
1285  return unbound;
1286 }
1287 
1288 
1289 
1290 
1291 //===================================================
1303 //===================================================
1304 atom_t compile_catch( context_t* ctx, atom_t source, int mode )
1305 {
1306  //printf("commands="); dumpln(source);
1307  atom_t params = CDR(source);
1308  atom_t tag_src = params;
1309  atom_t commands = CAR(CDR(params));
1310 
1311  // generate catch trampoline (prologue changes exit_addr)
1312  int old_exit_addr = ctx->exit_addr;
1313  int branch = asm_catch_prologue( ctx );
1314 
1315  // compile catch body
1316  atom_t y;
1317  y = compile_block( ctx, commands, mode );
1318  if( IS_ERROR(y) ) return y;
1319 
1320  // generate catch prologue and restore exit_addr
1321  ctx->exit_addr = old_exit_addr;
1322 
1323  // compile tag
1324  asm_label( ctx, TEXT("exit_catch:") );
1325  asm_fix( ctx, branch );
1326  //asm_int_3( ctx );
1327  if( mode==COMPILE_AS_PROC )
1328  asm_push_result( ctx );
1329  else
1330  asm_set_output_status( ctx, 0 );
1331  y = compile_expr( ctx, tag_src, COMPILE_AS_FUNC );
1332  if( IS_ERROR(y) ) return y;
1333  asm_catch_epilogue( ctx );
1334  //asm_exit_if_output( ctx );
1335  return empty_list;
1336 }
1337 
1338 
1339 
1340 
1341 //===================================================
1358 //===================================================
1360 {
1361  atom_t params = CDR(source);
1362  atom_t repcount_src = params;
1363  atom_t repcount = CAR(params);
1364  atom_t commands_lisp = CAR(CDR(params));
1365 
1366  int branch;
1367  int branch2 = -1;
1368 
1369  if( IS_LIST(repcount) )
1370  {
1371  try_expr:
1372  // REPEAT {expr} [...]
1373  branch = 0;
1374 
1375  atom_t y = compile_expr( ctx, repcount_src, COMPILE_AS_FUNC );
1376  if( IS_ERROR(y) ) return y;
1377 
1378  branch = asm_repeat_prologue_expr( ctx, repcount, &branch2 );
1379  }
1380  else
1381  {
1382  // REPEAT {const} [...]
1383  int64_t cnt;
1384  if( !atom_to_int( repcount, &cnt ) )
1385  goto try_expr;
1386  // return new_error_atom( ERROR_NOT_AN_INTEGER, repcount );
1387 
1388  if( cnt==0 )
1389  return unbound;
1390 
1391  if( cnt>INT_MAX )
1392  return new_error( ERROR_TOO_BIG_NUMBER, repcount );
1393 
1394  if( cnt<1 )
1395  return new_error( ERROR_TOO_SMALL_NUMBER, repcount );
1396 
1397  branch = asm_repeat_prologue_const( ctx, cnt );
1398  }
1399 
1400  atom_t y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
1401  if( IS_ERROR(y) ) return y;
1402 
1403  asm_repeat_epilogue( ctx, branch, branch2 );
1404 
1405  return unbound;
1406 }
1407 
1408 
1409 
1410 //===================================================
1418 //===================================================
1420 {
1421  atom_t commands_lisp = CAR(CDR(source));
1422 
1423  int branch = asm_forever_prologue( ctx );
1424 
1425  atom_t y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
1426  if( IS_ERROR(y) ) return y;
1427 
1428  asm_forever_epilogue( ctx, branch );
1429 
1430  return unbound;
1431 }
1432 
1433 
1434 
1435 //===================================================
1443 //===================================================
1445 {
1446  atom_t name = CAR(CDR(source));
1447  atom_t limits = CAR(CDR(CDR(source)));
1448  atom_t commands_lisp = CAR(CDR(CDR(CDR(source))));
1449 
1450  int branch = 0;
1451  int branch2 = -1;
1452 
1453  branch = 0;
1454 
1455  if( !IS_LIST(limits) || !GET_FLAGS(limits,FLAG_WAS_LIST_CONST) )
1456  {
1457  return new_error(ERROR_NOT_A_LIST_CONST,limits);
1458  }
1459 
1460  if( !IS_LIST(commands_lisp) || !GET_FLAGS(commands_lisp,FLAG_WAS_LIST_CONST) )
1461  {
1462  return new_error(ERROR_NOT_A_LIST_CONST,commands_lisp);
1463  }
1464 
1465  if( IS_EMPTY(limits) || IS_EMPTY(CDR(limits)) )
1466  {
1467  return new_error(ERROR_MISSING_FOR_LIMITS,source);
1468  }
1469 
1470  // compile initial limit
1471  atom_t y = compile_expr( ctx, limits, COMPILE_AS_FUNC );
1472  if( IS_ERROR(y) ) return y;
1473 
1474  // copy this limit to the control variable
1475  if( !IS_ANY_WORD(name)
1476  || LENGTH(name)<2
1477  || *STRING(name)!=TEXT('"') )
1478  return new_error( ERROR_NOT_A_WORD_CONST, name );
1479 
1480  if( !ctx->generate )
1481  {
1482  atom_t inc;
1483 
1484  atom_t qname = new_word( STRING(name), LENGTH(name) );
1485  *STRING(qname) = L':';
1486 
1487  atom_t cname = new_word( STRING(name), LENGTH(name)+1 );
1488  memmove( STRING(cname)+1, STRING(cname), LENGTH(name)*CHAR_SIZE );
1489  *STRING(cname) = L':';
1490  *(STRING(cname)+1) = L'^';
1491 
1492  inc = new_list(cname,empty_list);
1493  inc = new_list(qname,inc);
1494  inc = new_list(USE(word_plus),inc);
1496  inc = new_list(inc,empty_list);
1497  inc = new_list(USE(name),inc);
1498  inc = new_list(USE(word_make),inc);
1500 
1501  if( IS_EMPTY(commands_lisp) )
1502  {
1503  //printf("~1~\n");
1504  commands_lisp = new_list(inc,empty_list);
1505  CAR(CDR(CDR(CDR(source)))) = commands_lisp;
1507  }
1508  else
1509  {
1510  //printf("~2~\n");
1511  atom_t x = commands_lisp;
1512  while( !IS_EMPTY(CDR(x)) ) x = CDR(x);
1513  CDR(x) = new_list(inc,empty_list);
1514  }
1515  //printf("===========NEW LISP==="); dumpln(commands_lisp);
1516  }
1517 
1518  atom_t real_name = new_subword( name, STRING(name)+1, LENGTH(name)-1 );
1519  //printf("real name="); dumpln(real_name);
1520  //printf("parent="); dumpln(ctx->parent);
1521  atom_t control_var = find_var( real_name, ctx->parent );
1522  assert( control_var );
1523  DEUSE( real_name );
1524 
1525  atom_t step_name = new_word( STRING(name), LENGTH(name) );
1526  *STRING(step_name) = L'^';
1527  atom_t step_var = find_var( step_name, ctx->parent );
1528  assert( step_var );
1529  DEUSE( step_name );
1530 
1531  // new value of control var is already in stack,
1532  // duplicate it in otder to make: MAKE "<VAR> <FROM_VALUE>
1533  asm_pop_result( ctx );
1534  asm_push_result( ctx );
1535  asm_push_result( ctx );
1536  asm_make_direct( ctx, control_var, source );
1537 
1538  // compile final limit
1539  y = compile_expr( ctx, CDR(limits), COMPILE_AS_FUNC );
1540  if( IS_ERROR(y) ) return y;
1541 
1542  // compile step (if any)
1543  if( IS_NOT_EMPTY(CDR(CDR(limits))) )
1544  {
1545  y = compile_expr( ctx, CDR(CDR(limits)), COMPILE_AS_FUNC );
1546  if( IS_ERROR(y) ) return y;
1547  }
1548  else
1549  {
1550  asm_push_atom( ctx, unbound );
1551  }
1552 
1553  branch = asm_for_prologue( ctx, step_var, limits, &branch2 );
1554 
1555  y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
1556  if( IS_ERROR(y) ) return y;
1557 
1558  asm_for_epilogue( ctx, branch, branch2 );
1559 
1560  return unbound;
1561 }
1562 
1563 
1564 
1565 //===================================================
1579 //===================================================
1580 atom_t compile_while( context_t* ctx, atom_t source, int is_while, int is_do )
1581 {
1582  atom_t condition_src;
1583  //atom_t condition_lisp;
1584  atom_t commands_lisp;
1585  if( is_do )
1586  {
1587  condition_src = CDR(CDR(source));
1588  commands_lisp = CAR(CDR(source));
1589  }
1590  else
1591  {
1592  condition_src = CDR(source);
1593  commands_lisp = CAR(CDR(CDR(source)));
1594  }
1595  //condition_lisp = CAR(condition_src);
1596 
1597  //printf("condition = "); dumpln(condition_lisp);
1598  //printf("commands = "); dumpln(commands_lisp);
1599 
1600  int loop_branch = asm_while_prologue( ctx, is_while, is_do );
1601 
1602  if( is_do )
1603  {
1604  atom_t y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
1605  if( IS_ERROR(y) ) return y;
1606  }
1607 
1608  atom_t x = compile_expr( ctx, condition_src, COMPILE_AS_FUNC );
1609  if( IS_ERROR(x) ) return x;
1610 
1611  int skip_branch = asm_while_inlogue( ctx, commands_lisp, is_while );
1612 
1613  if( !is_do )
1614  {
1615  atom_t y = compile_block( ctx, commands_lisp, COMPILE_AS_PROC );
1616  if( IS_ERROR(y) ) return y;
1617  }
1618 
1619  asm_while_epilogue( ctx, loop_branch, skip_branch, is_while );
1620 
1621  return unbound;
1622 }
1623 
1624 
1625 
1626 
1627 //===================================================
1639 //===================================================
1640 atom_t compile_test( context_t* ctx, atom_t source, int criteria )
1641 {
1642  atom_t commands = CAR(CDR(source));
1643 
1644  //printf("condition = "); dumpln(condition_lisp);
1645  //printf("commands = "); dumpln(commands_lisp);
1646 
1647  int skip_branch = asm_test_prologue( ctx, criteria );
1648 
1649  atom_t y = compile_block( ctx, commands, COMPILE_AS_PROC );
1650  if( IS_ERROR(y) ) return y;
1651 
1652  asm_fix( ctx, skip_branch );
1653 
1654  return unbound;
1655 }
1656 
1657 
1658 
1659 
1660 //===================================================
1669 //===================================================
1671 {
1672  atom_t tag = CAR(CDR(source));
1673 
1674  if( !IS_ANY_WORD(tag) )
1675  return new_error( ERROR_NOT_A_WORD, tag );
1676 
1677  tag = new_subword( tag, STRING(tag)+1, LENGTH(tag)-1 );
1678 
1679  // remember the current position in generated code
1680  // only suring the first pass
1681  if( !ctx->generate )
1682  {
1683  atom_t var = new_var( tag, ctx->parent, 1 );
1684  VARTYPE( var ) = VAR_TYPE_TAG;
1685  VALUE( var ) = new_integer( ctx->size );
1686  SET_FLAGS( var, FLAG_VARIABLE );
1687  }
1688  else
1689  {
1690  if( OPTION_ASSEMBLER ) asm_label( ctx, STRING(tag) );
1691  }
1692 
1693  DEUSE( tag );
1694  return unbound;
1695 }
1696 
1697 
1698 
1699 
1700 //===================================================
1714 //===================================================
1716 {
1717  atom_t target_src = CDR(source);
1718  atom_t target = CAR(target_src);
1719 
1720  //printf("target="); dumpln(target);
1721 
1722  // try to find whether the target is known at compile-time
1723  if( IS_ANY_WORD(target)
1724  && LENGTH(target)>1
1725  && *STRING(target)==TEXT('"') )
1726  {
1727 
1728  // We have direct GOTO - i.e. we know the target's name
1729  atom_t real_name = new_subword( target, STRING(target)+1, LENGTH(target)-1 );
1730  atom_t var = find_local_var( real_name, ctx->parent );
1731  DEUSE( real_name );
1732 
1733  // test whether the target exists during
1734  // the second pass of the compilation
1735  if( ctx->generate && (!var || !IS_TAG(var)) )
1736  {
1737  return new_error( ERROR_NOT_A_TAG, target );
1738  }
1739  asm_goto( ctx, var );
1740  return unbound;
1741 
1742  }
1743 
1744  // the target is not a word-constant
1745 
1746  asm_goto_prologue( ctx, target ); // pushes target's source
1747 
1748  // prepare tag
1749  atom_t y = compile_expr( ctx, target_src, COMPILE_AS_FUNC );
1750  if( IS_ERROR(y) ) return y;
1751 
1752  asm_call_atom( ctx, var, 1 );
1753  asm_pop_atom( ctx ); // pop tag
1754  asm_pop_dummy ( ctx ); // pop source
1755  asm_goto_epilogue( ctx, target );
1756  return unbound;
1757 }
1758 
1759 
1760 
1761 
1762 //===================================================
1770 //===================================================
1772 {
1773  atom_t result = unbound;
1774 
1775  //printf("in===="); dumpln(source);
1776  atom_t name;
1777  if( IS_ANY_WORD(source) )
1778  name = source;
1779  else
1780  name = CAR(source);
1781  atom_t real_name = new_subword( name, STRING(name)+1, LENGTH(name)-1 );
1782  atom_t var = find_var( real_name, ctx->parent );
1783  if( var && IS_NORMAL(var) )
1784  {
1785  if( IS_VARIABLE( var ) )
1786  {
1787  // existing variable
1788  asm_reference( ctx, var, source, 1 );
1789  }
1790  else
1791  result = new_error( ERROR_NOT_A_VAR, name );
1792  }
1793  else
1794  {
1795  // NON-existing variable
1796  compile_lisp_const( ctx, name );
1797  asm_runtime_reference( ctx );
1798  asm_pop_atom( ctx );
1799  asm_push_result( ctx );
1800  }
1801  DEUSE( real_name );
1802 
1803  return result;
1804 }
1805 
1806 
1807 
1808 //===================================================
1828 //===================================================
1829 atom_t compile_expr( context_t* ctx, atom_t lisp, int mode )
1830 {
1831 #define RETURN_NO_CHECK(INSTR) \
1832  { \
1833  result = INSTR; \
1834  needs_check = 0; \
1835  goto finalize; \
1836  }
1837 #define RETURN_NO_CHECK_EL(INSTR) \
1838  { \
1839  result = INSTR; \
1840  if( !IS_ERROR(result) ) result = empty_list;\
1841  needs_check = 0; \
1842  goto finalize; \
1843  }
1844 #define RETURN_CHECK(INSTR) \
1845  { \
1846  result = INSTR; \
1847  needs_check = 1; \
1848  goto finalize; \
1849  }
1850 
1851  atom_t orig_lisp = lisp;
1852  lisp = CAR(lisp);
1853 
1854  int needs_check = 1;
1855  atom_t result = unbound;
1856 
1857  #ifdef DEBUG_COMPILE
1858  printf("<COMPILE> Compile expression: "); dumpln(lisp);
1859  #endif
1860 
1861  // remove extra parentheses
1862  if( IS_LIST(lisp) )
1863  if( !IS_EMPTY(lisp) )
1864  if( IS_EXPRESSION(lisp) )
1865  while( IS_LIST(CAR(lisp)) && IS_EXPRESSION(CAR(lisp)) && IS_EMPTY(CDR(lisp)) )
1866  lisp = CAR(lisp);
1867 
1868  #ifdef DEBUG_COMPILE
1869  printf("<COMPILE> Normalized expression: "); dumpln(lisp);
1870  if( IS_LIST(lisp) && IS_EXTENDED(lisp) )
1871  {
1872  printf("<COMPILE>It's source is: |");
1873  dump(POS(lisp));
1874  printf("|\n");
1875  }
1876  #endif
1877 
1878  // if the source is a constant, then just push it
1879  if( is_constant(lisp) )
1880  {
1881  if( mode==COMPILE_AS_PROC )
1882  {
1883  if( IS_EXTENDED(lisp) && !IS_UNBOUND(POS(lisp)) )
1884  return new_error( ERROR_UNUSED_VALUE, POS(lisp) );
1885  else
1886  if( IS_EXTENDED(orig_lisp) && !IS_UNBOUND(POS(orig_lisp)) )
1887  return new_error( ERROR_UNUSED_VALUE, POS(orig_lisp) );
1888  else
1889  return new_error( ERROR_UNUSED_VALUE, lisp );
1890  }
1892  }
1893 
1894  // test whether the source is a reference
1895  if( is_reference( lisp ) )
1896  {
1897  if( mode==COMPILE_AS_PROC )
1898  return new_error( ERROR_UNUSED_VALUE, lisp );
1900  }
1901 
1902  // the source is not a constant and cannot be just pushed
1903  INFO( "" );
1904  INFO( "code for %a", lisp );
1905 
1906  // find the main function of the expression
1907  // it must be known variable
1908  atom_t varname = CAR( lisp );
1909  #ifdef SAFEMODE
1910  assert( IS_ANY_WORD(varname) );
1911  #endif
1912 
1913  if( LENGTH(varname)==1 && *STRING(varname)==TEXT('"') )
1914  {
1915  return new_error( ERROR_DO_NOT_KNOW, lisp );
1916  }
1917 
1918  atom_t var = find_var( varname, ctx->parent );
1919  #ifdef SAFEMODE
1920  assert( var );
1921  #endif
1922 
1923  // variables cannot be commands and procedures
1924  if( IS_VARIABLE(var) )
1925  return new_error( ERROR_NOT_A_FUNCTION, lisp );
1926 
1927  // commands do not return values
1928  if( (mode==COMPILE_AS_FUNC) && !IS_FUNCTION(var) )
1929  return new_error( ERROR_MISSING_VALUE, lisp );
1930 
1931  //printf("var="); dumpln(NAME(var));
1932 
1933  int addr = ADDRESS(var);
1934  #ifdef SAFEMODE
1935  if( IS_PRIMITIVE(var) ) assert( addr );
1936  #endif
1937 
1938  // dump source which is about to be executed or evaluated
1939  #ifdef ADVANCED
1940  if( OPTION_RUNTIME )
1941  {
1942  asm_dump_source( ctx, lisp );
1943  }
1944  #endif
1945 
1946 
1947  // SPECIAL COMPILATION CASES
1948  {
1949  // 0. _int3_
1950  if( addr==(int)rt_int3 )
1951  {
1952  asm_int_3( ctx );
1954  }
1955 
1956  // 1. local <name>
1957  if( addr==(int)rt_local )
1958  {
1959  int processed;
1960  result = compile_local( ctx, lisp, &processed );
1961  if( processed ) RETURN_NO_CHECK( result );
1962  }
1963 
1964  // 2. make <name> <value>
1965  if( addr==(int)rt_make )
1966  {
1967  int processed;
1968  result = compile_make( ctx, lisp, 0, &processed );
1969  //printf("processed make=%d\n",processed);
1970  if( processed ) RETURN_NO_CHECK( result );
1971  }
1972 
1973  // 3. name <value> <name>
1974  if( addr==(int)rt_name )
1975  {
1976  int processed;
1977  result = compile_make( ctx, lisp, 1, &processed );
1978  if( processed ) RETURN_NO_CHECK( result );
1979  }
1980 
1981  // 4a. output <value>
1982  if( addr==(int)rt_output )
1983  RETURN_NO_CHECK( compile_output(ctx,lisp) );
1984 
1985  // 4b. maybeoutput <value>
1986  if( addr==(int)rt_maybeoutput )
1987  RETURN_NO_CHECK( compile_maybeoutput(ctx,lisp) );
1988 
1989  // 5. stop
1990  if( addr==(int)rt_stop )
1991  RETURN_NO_CHECK( compile_stop(ctx,lisp) );
1992 
1993  // 6. if
1994  if( addr==(int)rt_if )
1995  RETURN_NO_CHECK( compile_if(ctx,lisp,mode) );
1996 
1997  // 7. repeat
1998  if( addr==(int)rt_repeat )
1999  RETURN_NO_CHECK( compile_repeat(ctx,lisp) );
2000 
2001  // 8. forever
2002  if( addr==(int)rt_forever )
2003  RETURN_NO_CHECK( compile_forever(ctx,lisp) );
2004 
2005  // 9. while
2006  if( addr==(int)rt_while )
2007  RETURN_NO_CHECK( compile_while(ctx,lisp,1,0) );
2008 
2009  // 10. until
2010  if( addr==(int)rt_until )
2011  RETURN_NO_CHECK( compile_while(ctx,lisp,0,0) );
2012 
2013  // 11. do.while
2014  if( addr==(int)rt_dowhile )
2015  RETURN_NO_CHECK( compile_while(ctx,lisp,1,1) );
2016 
2017  // 12. do.until
2018  if( addr==(int)rt_dountil )
2019  RETURN_NO_CHECK( compile_while(ctx,lisp,0,1) );
2020 
2021  // 13. catch
2022  if( addr==(int)rt_catch )
2023  RETURN_CHECK( compile_catch(ctx,lisp,mode) );
2024 
2025  // 14. tag
2026  if( addr==(int)rt_tag )
2027  RETURN_NO_CHECK( compile_tag(ctx,lisp) );
2028 
2029  // 15. goto
2030  if( addr==(int)rt_goto )
2031  RETURN_NO_CHECK( compile_goto(ctx,lisp,var) );
2032 
2033  // 16. iftrue
2034  if( addr==(int)rt_iftrue )
2035  RETURN_NO_CHECK( compile_test(ctx,lisp,1) );
2036 
2037  // 17. iffalse
2038  if( addr==(int)rt_iffalse )
2039  RETURN_NO_CHECK( compile_test(ctx,lisp,0) );
2040 
2041  // 18. for
2042  if( addr==(int)rt_for )
2043  RETURN_NO_CHECK( compile_for(ctx,lisp) );
2044 
2045  }
2046  // END OF SPECIAL COMPILATION CASES
2047 
2048 
2049  if( GET_FLAGS(var,FLAG_PUSH_MODE) )
2050  asm_push_mode( ctx, mode );
2051 
2052  if( GET_FLAGS(var,FLAG_PUSH_FRAME) )
2053  asm_push_frame( ctx );
2054 
2055  int params = 0;
2056  atom_t x;
2057  atom_t y;
2058  if( !IS_PRIMITIVE(var) && GET_FLAGS(var,FLAG_INFINITE_ARGS) )
2059  {
2060  //printf("<COMPILE> Compile func: "); dumpln(NAME(var));
2061  //printf("<COMPILE> LARGS=%d RARGS=%d\n",LARGS(var),RARGS(var));
2062 
2063  // skip number of compulsory params
2064  int skip;
2065  x = CDR(lisp);
2066  for( skip = LARGS(var)+RARGS(var); skip; skip-- )
2067  {
2068  if( IS_NOT_EMPTY(x) ) x = CDR(x);
2069  }
2070  // process all extra parameters
2071  for( ; IS_NOT_EMPTY(x); x=CDR(x) )
2072  {
2073  #ifdef DEBUG_COMPILE
2074  printf("<COMPILE> Compile parameter: "); dumpln(CAR(x));
2075  #endif
2076  y = compile_expr( ctx, x, COMPILE_AS_FUNC );
2077  if( IS_ERROR(y) ) return y;
2078  params++;
2079  }
2080  // process compulsory params
2081  x = CDR(lisp);
2082  for( skip = LARGS(var)+RARGS(var); skip; skip-- )
2083  {
2084  if( IS_NOT_EMPTY(x) )
2085  {
2086  #ifdef DEBUG_COMPILE
2087  printf("<COMPILE> Compile parameter: "); dumpln(CAR(x));
2088  #endif
2089  y = compile_expr( ctx, x, COMPILE_AS_FUNC );
2090  if( IS_ERROR(y) ) return y;
2091  x = CDR(x);
2092  }
2093  else
2094  {
2095  // Compile dummy parameter
2096  asm_push_atom( ctx, empty_list );
2097  }
2098  params++;
2099  }
2100  }
2101  else
2102  {
2103  for( x=CDR(lisp); IS_NOT_EMPTY(x); x=CDR(x) )
2104  {
2105  #ifdef DEBUG_COMPILE
2106  printf("<COMPILE> Compile parameter: "); dumpln(CAR(x));
2107  #endif
2108  y = compile_expr( ctx, x, COMPILE_AS_FUNC );
2109  if( IS_ERROR(y) ) return y;
2110  params++;
2111  }
2112  }
2113 
2114  asm_call_atom( ctx, var, params );
2115 
2116  int i;
2117  for( i=params-1; i>=0; i-- )
2118  {
2119  asm_pop_atom( ctx );
2120  }
2121 
2122  if( GET_FLAGS(var,FLAG_PUSH_FRAME) )
2123  asm_pop_frame( ctx );
2124 
2125  if( GET_FLAGS(var,FLAG_PUSH_MODE) )
2126  asm_pop_dummy( ctx );
2127 
2128  // special case for RUN, RUNMACRO and RUNRESULT - they return
2129  // a var atom containing the actual code to execute.
2130  if( addr==(int)rt_run ) { asm_run_epilogue( ctx ); }
2131  if( addr==(int)rt_runmacro ) { asm_run_epilogue( ctx ); }
2132  if( addr==(int)rt_runresult ) { asm_runresult_epilogue( ctx ); }
2133 
2134  asm_push_result( ctx );
2135  //disasm_atom( ctx, NAME(var) );
2136 
2137  finalize:
2138  if( needs_check )
2139  {
2140  if( mode==COMPILE_AS_FUNC ) asm_result_func( ctx, lisp );
2141  if( mode==COMPILE_AS_PROC ) asm_result_proc( ctx, lisp );
2142  if( mode==COMPILE_AS_UNKNOWN ) asm_result_unknown( ctx, lisp );
2143  }
2144  return result;
2145 }
2146 
2147 
2148 
2149 
2150 //===================================================
2162 //===================================================
2163 atom_t compile_block( context_t* ctx, atom_t lisp, int mode )
2164 {
2165  //printf("compile_block "); dumpln(lisp);
2166  //printf("mode=%d (func=%d cmd=%d unknown=%d)\n",mode,COMPILE_AS_FUNC,COMPILE_AS_PROC,COMPILE_AS_UNKNOWN);
2167 
2168  if( (mode==COMPILE_AS_FUNC) && IS_NOT_EMPTY(CDR(lisp)) )
2169  return new_error( ERROR_CROWDED_EXPRESSION, CDR(lisp) );
2170 
2171  if( mode==COMPILE_AS_UNKNOWN )
2172  if( IS_NOT_EMPTY(lisp) && IS_NOT_EMPTY(CDR(lisp)) )
2173  mode = COMPILE_AS_PROC;
2174 
2175  // there is a word
2176  if( IS_ANY_WORD(lisp) )
2177  {
2178  return new_error(ERROR_NOT_A_LIST_CONST,lisp);
2179  }
2180 
2181  // there is a lisp which is not produced by
2182  // a constant list
2183  if( !GET_FLAGS(lisp,FLAG_WAS_LIST_CONST) )
2184  {
2185  return new_error(ERROR_NOT_A_LIST_CONST,lisp);
2186  }
2187 
2188  atom_t x;
2189  for( x=lisp; IS_NOT_EMPTY(x); x=CDR(x) )
2190  {
2191  #ifdef DEBUG_COMPILE
2192  printf("<COMPILE> Compile command: "); dumpln(CAR(x));
2193  #endif
2194 
2195  atom_t y = compile_expr( ctx, x, mode );
2196  if( IS_ERROR(y) ) return y;
2197 
2198  // do not leave results in the stack
2199  if( IS_EMPTY(y) && mode==COMPILE_AS_UNKNOWN )
2200  asm_pop_result( ctx );
2201 
2202  #ifdef DEBUG_COMPILE
2203  printf("<COMPILE> Command compiled!\n");
2204  #endif
2205  }
2206 
2207  if( IS_EMPTY(lisp) )
2208  {
2209  if( mode==COMPILE_AS_FUNC )
2210  {
2211  asm_empty_body( ctx );
2212  asm_push_result( ctx );
2213  }
2214  }
2215  return unbound;
2216 }

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