maug
Quick and dirty C mini-augmentation library.
mlispe.h
Go to the documentation of this file.
1
2#ifndef MLISPE_H
3#define MLISPE_H
4
5#include <mlisps.h>
6
43#ifndef MLISP_TOKEN_SZ_MAX
44# define MLISP_TOKEN_SZ_MAX 4096
45#endif /* !MLISP_TOKEN_SZ_MAX */
46
47#ifndef MLISP_EXEC_TRACE_LVL
48# define MLISP_EXEC_TRACE_LVL 0
49#endif /* !MLISP_EXEC_TRACE_LVL */
50
51#ifndef MLISP_STEP_TRACE_LVL
52# define MLISP_STEP_TRACE_LVL 0
53#endif /* !MLISP_STEP_TRACE_LVL */
54
55#ifndef MLISP_CMP_TRACE_LVL
56# define MLISP_CMP_TRACE_LVL 0
57#endif /* !MLISP_CMP_TRACE_LVL */
58
59#ifndef MLISP_ENV_TRACE_LVL
60# define MLISP_ENV_TRACE_LVL 0
61#endif /* !MLISP_ENV_TRACE_LVL */
62
63#ifndef MLISP_LOCK_TRACE_LVL
64# define MLISP_LOCK_TRACE_LVL 0
65#endif /* !MLISP_LOCK_TRACE_LVL */
66
67#ifndef MLISP_STACK_TRACE_LVL
68# define MLISP_STACK_TRACE_LVL 0
69#endif /* !MLISP_STACK_TRACE_LVL */
70
71#define MLISP_ENV_FLAG_BUILTIN 0x02
72
74#define MLISP_ENV_FLAG_CMP_GT 0x10
75
77#define MLISP_ENV_FLAG_CMP_LT 0x20
78
80#define MLISP_ENV_FLAG_CMP_EQ 0x40
81
83#define MLISP_ENV_FLAG_ARI_ADD 0x10
84
86#define MLISP_ENV_FLAG_ARI_MUL 0x20
87
88#define MLISP_ENV_FLAG_ARI_DIV 0x40
89
90#define MLISP_ENV_FLAG_ARI_MOD 0x80
91
92#define MLISP_ENV_FLAG_ANO_OR 0x10
93
94#define MLISP_ENV_FLAG_ANO_AND 0x20
95
97#define MLISP_ENV_FLAG_DEFINE_GLOBAL 0x10
98
99#define MLISP_AUTOLOCK_EXEC_ENV 0x01
100
101#define MLISP_AUTOLOCK_CHILD_IDX 0x02
102
103#define MLISP_AUTOLOCK_VISIT_CT 0x04
104
105#define MLISP_AUTOLOCK_PARSER_AST 0x08
106
107#define MLISP_AUTOLOCK_GLOBAL_ENV 0x10
108
118#define MLISP_STACK_FLAG_PEEK 0x01
119
123#define mlisp_stack_pop( exec, o ) mlisp_stack_pop_ex( exec, o, 0 )
124
133#define mlisp_stack_push( exec, i, ctype ) \
134 (_mlisp_stack_push_ ## ctype( exec, (ctype)i ))
135
136#if defined( MLISP_DUMP_ENABLED ) || defined( DOCUMENTATION )
137
144 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec );
145
146#endif /* MLISP_DUMP_ENABLED || DOCUMENTATION */
147
155 struct MLISP_EXEC_STATE* exec, struct MLISP_STACK_NODE* o, uint8_t flags );
156 /* mlisp_stack */
158
159#if defined( MLISP_DUMP_ENABLED ) || defined( DOCUMENTATION )
160
167 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, uint8_t global );
168
169#endif /* MLISP_DUMP_ENABLED || DOCUMENTATION */
170
171struct MLISP_ENV_NODE* mlisp_env_get(
172 struct MLISP_EXEC_STATE* exec, const char* key );
173
174MERROR_RETVAL mlisp_env_unset(
175 struct MLISP_EXEC_STATE* exec, const char* token, size_t token_sz,
176 uint8_t global );
177
178MERROR_RETVAL mlisp_env_set(
179 struct MLISP_EXEC_STATE* exec,
180 const char* token, size_t token_sz, uint8_t env_type, const void* data,
181 uint8_t global, uint8_t flags );
182
183ssize_t mlisp_count_builtins( struct MLISP_EXEC_STATE* exec );
184
185MERROR_RETVAL mlisp_check_state(
186 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec );
187
194 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec );
195
208 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec,
209 const char* lambda );
210
211MERROR_RETVAL mlisp_exec_add_env_builtins(
212 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec );
213
214MERROR_RETVAL mlisp_exec_init(
215 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, uint8_t flags );
216
222 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec,
223 struct MDATA_TABLE* global_env );
224
225void mlisp_exec_free( struct MLISP_EXEC_STATE* exec );
226
227MERROR_RETVAL mlisp_deserialize_prepare_EXEC_STATE(
228 struct MLISP_EXEC_STATE* exec, size_t i );
229
230#define _MLISP_TYPE_TABLE_PUSH_PROTO( idx, ctype, name, const_name, fmt ) \
231 MERROR_RETVAL _mlisp_stack_push_ ## ctype( \
232 struct MLISP_EXEC_STATE* exec, ctype i );
233
234MLISP_TYPE_TABLE( _MLISP_TYPE_TABLE_PUSH_PROTO )
235
236 /* mlisp */
237
238#define mlisp_ast_has_ready_children( exec_child_idx, n ) \
239 ((exec_child_idx) < (n)->ast_idx_children_sz)
240
241#ifdef MLISPE_C
242
243uint16_t g_mlispe_last_uid = 0;
244
255static MERROR_RETVAL _mlisp_preempt(
256 MERROR_RETVAL retval, const char* caller, struct MLISP_PARSER* parser,
257 size_t n_idx, struct MLISP_EXEC_STATE* exec, size_t new_idx );
258
259static MERROR_RETVAL _mlisp_step_iter(
260 struct MLISP_PARSER* parser,
261 size_t n_idx, struct MLISP_EXEC_STATE* exec );
262
263static MERROR_RETVAL _mlisp_reset_child_pcs(
264 const struct MLISP_PARSER* parser,
265 size_t n_idx, struct MLISP_EXEC_STATE* exec );
266
267static MERROR_RETVAL _mlisp_autolock(
268 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec,
269 uint8_t mask, uint8_t autolock[MLISP_EXEC_ENV_FRAME_CT_MAX]
270) {
271 MERROR_RETVAL retval = MERROR_OK;
272 int8_t env_iter = 0;
273
274 maug_mzero( autolock, MLISP_EXEC_ENV_FRAME_CT_MAX );
275
276 /* Autolock vectors used below. */
277 if( MLISP_AUTOLOCK_EXEC_ENV == (MLISP_AUTOLOCK_EXEC_ENV & mask) ) {
278 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
279 if( !mdata_table_is_locked( &(exec->env[env_iter]) ) ) {
280#if MLISP_LOCK_TRACE_LVL > 0
281 debug_printf( MLISP_LOCK_TRACE_LVL,
282 "%u: engaging autolock for exec env frame %d...",
283 exec->uid, env_iter );
284#endif /* MLISP_LOCK_TRACE_LVL */
285 mdata_table_lock( &(exec->env[env_iter]) );
286 autolock[env_iter] |= MLISP_AUTOLOCK_EXEC_ENV;
287 }
288 }
289 }
290 if(
291 MLISP_AUTOLOCK_CHILD_IDX == (MLISP_AUTOLOCK_CHILD_IDX & mask) &&
292 !mdata_vector_is_locked( &(exec->per_node_child_idx) )
293 ) {
294#if MLISP_LOCK_TRACE_LVL > 0
295 debug_printf( MLISP_LOCK_TRACE_LVL,
296 "%u: engaging autolock for exec per-node child index...", exec->uid );
297#endif /* MLISP_LOCK_TRACE_LVL */
299 autolock[0] |= MLISP_AUTOLOCK_CHILD_IDX;
300 }
301 if(
302 MLISP_AUTOLOCK_VISIT_CT == (MLISP_AUTOLOCK_VISIT_CT & mask) &&
303 !mdata_vector_is_locked( &(exec->per_node_visit_ct) )
304 ) {
305#if MLISP_LOCK_TRACE_LVL > 0
306 debug_printf( MLISP_LOCK_TRACE_LVL,
307 "%u: engaging autolock for per-node visit count...", exec->uid );
308#endif /* MLISP_LOCK_TRACE_LVL */
310 autolock[0] |= MLISP_AUTOLOCK_VISIT_CT;
311 }
312 if(
313 MLISP_AUTOLOCK_PARSER_AST == (MLISP_AUTOLOCK_PARSER_AST & mask) &&
314 !mdata_vector_is_locked( &(parser->ast) )
315 ) {
316#if MLISP_LOCK_TRACE_LVL > 0
317 debug_printf( MLISP_LOCK_TRACE_LVL,
318 "%u: engaging autolock for parser AST...", exec->uid );
319#endif /* MLISP_LOCK_TRACE_LVL */
320 mdata_vector_lock( &(parser->ast) );
321 autolock[0] |= MLISP_AUTOLOCK_PARSER_AST;
322 }
323 if(
324 MLISP_AUTOLOCK_GLOBAL_ENV == (MLISP_AUTOLOCK_GLOBAL_ENV & mask) &&
325 NULL != exec->global_env &&
326 0 < mdata_table_ct( exec->global_env ) &&
327 !mdata_table_is_locked( exec->global_env )
328 ) {
329#if MLISP_LOCK_TRACE_LVL > 0
330 debug_printf( MLISP_LOCK_TRACE_LVL,
331 "%u: engaging autolock for global env...", exec->uid );
332#endif /* MLISP_LOCK_TRACE_LVL */
333 mdata_table_lock( exec->global_env );
334 autolock[0] |= MLISP_AUTOLOCK_GLOBAL_ENV;
335 }
336
337cleanup:
338 return retval;
339}
340
341/* === */
342
343static void _mlisp_autounlock(
344 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec,
345 uint8_t autolock[MLISP_EXEC_ENV_FRAME_CT_MAX]
346) {
347 int8_t env_iter = 0;
348 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
349 if(
350 MLISP_AUTOLOCK_EXEC_ENV ==
351 (MLISP_AUTOLOCK_EXEC_ENV & autolock[env_iter])
352 ) {
353 mdata_table_unlock( &(exec->env[env_iter]) );
354 }
355 }
356 if( MLISP_AUTOLOCK_CHILD_IDX == (MLISP_AUTOLOCK_CHILD_IDX & autolock[0]) ) {
358 }
359 if( MLISP_AUTOLOCK_VISIT_CT == (MLISP_AUTOLOCK_VISIT_CT & autolock[0]) ) {
361 }
362 if(
363 MLISP_AUTOLOCK_PARSER_AST == (MLISP_AUTOLOCK_PARSER_AST & autolock[0])
364 ) {
365 mdata_vector_unlock( &(parser->ast) );
366 }
367 if(
368 MLISP_AUTOLOCK_GLOBAL_ENV == (MLISP_AUTOLOCK_GLOBAL_ENV & autolock[0])
369 ) {
370 mdata_table_unlock( exec->global_env );
371 }
372}
373
374/* === */
375
376/* Stack Functions */
377
378/* === */
379
380#ifdef MLISP_DUMP_ENABLED
381
383 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec
384) {
385 MERROR_RETVAL retval = MERROR_OK;
386 size_t i = 0;
387 struct MLISP_STACK_NODE* n_stack = NULL;
388
389# define _MLISP_TYPE_TABLE_DUMPS( idx, ctype, name, const_name, fmt ) \
390 } else if( MLISP_TYPE_ ## const_name == n_stack->type ) { \
391 debug_printf( MLISP_STACK_TRACE_LVL, \
392 "%u: " MLISP_TRACE_SIGIL " stack " SIZE_T_FMT " (" #const_name "): " fmt, \
393 exec->uid, i, n_stack->value.name );
394
395 mdata_vector_lock( &(exec->stack) );
396 mdata_strpool_lock( &(parser->strpool) ); \
397 while( i < mdata_vector_ct( &(exec->stack) ) ) {
398 n_stack = mdata_vector_get( &(exec->stack), i, struct MLISP_STACK_NODE );
399
400 /* Handle special exceptions. */
401 if( MLISP_TYPE_STR == n_stack->type ) {
402 debug_printf( 1,
403 "%u: " MLISP_TRACE_SIGIL " stack " SIZE_T_FMT " (STR): %s",
404 exec->uid, i, mdata_strpool_get(
405 &(parser->strpool), n_stack->value.strpool_idx ) );
406
407 } else if( MLISP_TYPE_CB == n_stack->type ) {
408 debug_printf( 1,
409 "%u: " MLISP_TRACE_SIGIL " stack " SIZE_T_FMT " (CB): %p",
410 exec->uid, i, n_stack->value.cb );
411
412 } else if( MLISP_TYPE_LAMBDA == n_stack->type ) {
413 debug_printf( 1,
414 "%u: " MLISP_TRACE_SIGIL " stack " SIZE_T_FMT " (LAMBDA): "
415 SIZE_T_FMT,
416 exec->uid, i, n_stack->value.lambda );
417
418 /*
419 } else if( MLISP_TYPE_ARGS_S == n_stack->type ) {
420 debug_printf( 1,
421 "%u: " MLISP_TRACE_SIGIL " stack " SIZE_T_FMT " (ARGS_S): "
422 SIZE_T_FMT,
423 exec->uid, i, n_stack->value.args_start );
424
425 } else if( MLISP_TYPE_ARGS_E == n_stack->type ) {
426 debug_printf( 1,
427 "%u: " MLISP_TRACE_SIGIL " stack " SIZE_T_FMT " (ARGS_E): "
428 SIZE_T_FMT,
429 exec->uid, i, n_stack->value.args_end );
430 */
431
432 } else if( MLISP_TYPE_BEGIN == n_stack->type ) {
433 debug_printf( 1,
434 "%u: " MLISP_TRACE_SIGIL " stack " SIZE_T_FMT " (BEGIN): "
435 SIZE_T_FMT,
436 exec->uid, i, n_stack->value.begin );
437
438 /* Handle numeric types. */
439 MLISP_NUM_TYPE_TABLE( _MLISP_TYPE_TABLE_DUMPS );
440 } else {
441 error_printf( "invalid stack type: %u", n_stack->type );
442 }
443 i++;
444 }
445 mdata_strpool_unlock( &(parser->strpool) );
446 mdata_vector_unlock( &(exec->stack) );
447
448cleanup:
449
450 assert( mdata_strpool_is_locked( &(parser->strpool) ) );
451
452 return retval;
453}
454
455#endif /* MLISP_DUMP_ENABLED */
456
457/* === */
458
459#define _MLISP_TYPE_TABLE_PUSH( idx, ctype, name, const_name, fmt ) \
460 MERROR_RETVAL _mlisp_stack_push_ ## ctype( \
461 struct MLISP_EXEC_STATE* exec, ctype i \
462 ) { \
463 ssize_t stack_idx = 0; \
464 struct MLISP_STACK_NODE n_stack; \
465 MERROR_RETVAL retval = MERROR_OK; \
466 debug_printf( MLISP_STACK_TRACE_LVL, \
467 "%u: pushing " #const_name " onto stack: " fmt, exec->uid, i ); \
468 n_stack.type = MLISP_TYPE_ ## const_name; \
469 n_stack.value.name = i; \
470 stack_idx = mdata_vector_append( \
471 &(exec->stack), &n_stack, sizeof( struct MLISP_STACK_NODE ) ); \
472 if( 0 > stack_idx ) { \
473 retval = mdata_retval( stack_idx ); \
474 } \
475 return retval; \
476 }
477
478MLISP_TYPE_TABLE( _MLISP_TYPE_TABLE_PUSH );
479
480/* === */
481
483 struct MLISP_EXEC_STATE* exec, struct MLISP_STACK_NODE* o, uint8_t flags
484) {
485 MERROR_RETVAL retval = MERROR_OK;
486 struct MLISP_STACK_NODE* n_stack = NULL;
487 size_t n_idx = 0;
488
489 maug_mzero( o, sizeof( struct MLISP_STACK_NODE ) );
490
491 /* Check for valid stack pointer. */
492 maug_cleanup_if_eq(
493 mdata_vector_ct( &(exec->stack) ), 0, SIZE_T_FMT, MERROR_OVERFLOW );
494
495 n_idx = mdata_vector_ct( &(exec->stack) ) - 1;
496
497 /* Perform the pop! */
498 mdata_vector_lock( &(exec->stack) );
499 n_stack = mdata_vector_get(
500 &(exec->stack), n_idx, struct MLISP_STACK_NODE );
501 assert( NULL != n_stack );
502 memcpy( o, n_stack, sizeof( struct MLISP_STACK_NODE ) );
503 n_stack = NULL;
504 mdata_vector_unlock( &(exec->stack) );
505
506#if MLISP_STACK_TRACE_LVL > 0
507# define _MLISP_TYPE_TABLE_POPD( idx, ctype, name, const_name, fmt ) \
508 } else if( MLISP_TYPE_ ## const_name == o->type ) { \
509 if( MLISP_STACK_FLAG_PEEK == (MLISP_STACK_FLAG_PEEK & flags) ) { \
510 debug_printf( MLISP_STACK_TRACE_LVL, \
511 "%u: peeking (%ut): " SSIZE_T_FMT ": " fmt, \
512 exec->uid, n_idx, o->type, o->value.name ); \
513 } else { \
514 debug_printf( MLISP_STACK_TRACE_LVL, \
515 "%u: popping (%ut): " SSIZE_T_FMT ": " fmt, \
516 exec->uid, n_idx, o->type, o->value.name ); \
517 }
518
519 if( 0 ) {
520 MLISP_TYPE_TABLE( _MLISP_TYPE_TABLE_POPD )
521 }
522#endif /* MLISP_STACK_TRACE_LVL */
523
525 retval = mdata_vector_remove( &(exec->stack), n_idx );
526 }
527
528cleanup:
529
530 return retval;
531}
532
533/* === */
534
535/* Env Functons */
536
537/* === */
538
539#if defined( MLISP_DUMP_ENABLED )
540
541static MERROR_RETVAL _mlisp_env_dump_iter(
542 const struct MDATA_TABLE_KEY* key, void* data, size_t data_sz,
543 void* cb_data, size_t cb_data_sz, size_t idx
544) {
545 MERROR_RETVAL retval = MERROR_OK;
546 struct MLISP_ENV_NODE* e = (struct MLISP_ENV_NODE*)data;
547 struct MLISP_PARSER parser;
548 struct MLISP_EXEC_STATE* exec = (struct MLISP_EXEC_STATE*)cb_data;
549
550 maug_mzero( &parser, sizeof( struct MLISP_PARSER ) );
551
552# define _MLISP_TYPE_TABLE_DUMPE( idx, ctype, name, const_name, fmt ) \
553 } else if( MLISP_TYPE_ ## const_name == e->type ) { \
554 debug_printf( 1, \
555 "%u: " MLISP_TRACE_SIGIL " env \"%s\" (" #const_name "): " fmt, \
556 exec->uid, key->string, e->value.name );
557
558 if( MLISP_ENV_FLAG_BUILTIN == (MLISP_ENV_FLAG_BUILTIN & e->flags) ) {
559 /* Skip builtins. */
560 return MERROR_OK;
561 }
562
563 debug_printf( 1, "%s: %p: 0x%02x", key, e, e->type );
564
565 if( 0 ) {
566 MLISP_NUM_TYPE_TABLE( _MLISP_TYPE_TABLE_DUMPE );
567 /* Handle special exceptions. */
568 } else if( MLISP_TYPE_STR == e->type ) {
569 debug_printf( 1,
570 "%u: " MLISP_TRACE_SIGIL " env \"%s\" (STR): %s",
571 exec->uid, key,
572 mdata_strpool_get( &(parser.strpool), e->value.strpool_idx ) );
573
574 } else if( MLISP_TYPE_CB == e->type ) {
575 debug_printf( 1,
576 "%u: " MLISP_TRACE_SIGIL " env \"%s\" (CB): %p",
577 exec->uid, key, e->value.cb );
578
579 } else if( MLISP_TYPE_LAMBDA == e->type ) {
580 debug_printf( 1,
581 "%u: " MLISP_TRACE_SIGIL " env \"%s\" (LAMBDA): " SIZE_T_FMT,
582 exec->uid, key, e->value.lambda );
583
584 } else {
585 error_printf( MLISP_TRACE_SIGIL " invalid env type: %u", e->type );
586 }
587
588 return retval;
589}
590
591/* === */
592
594 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, uint8_t global
595) {
596 MERROR_RETVAL retval = MERROR_OK;
597 int8_t env_iter = 0;
598 uint8_t autolock[MLISP_EXEC_ENV_FRAME_CT_MAX];
599
600 retval = _mlisp_autolock(
601 NULL, exec, MLISP_AUTOLOCK_EXEC_ENV | MLISP_AUTOLOCK_GLOBAL_ENV,
602 autolock );
603 maug_cleanup_if_not_ok();
604
605 if( global ) {
606 debug_printf( 1, "# global env:" );
607 retval = mdata_table_iter(
608 exec->global_env, _mlisp_env_dump_iter, exec, 0 );
609 } else {
610 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
611 debug_printf( 1, "# env frame %d:", env_iter );
612 retval = mdata_table_iter(
613 &(exec->env[env_iter]), _mlisp_env_dump_iter, exec, 0 );
614 maug_cleanup_if_not_ok();
615 }
616 }
617
618cleanup:
619
620 _mlisp_autounlock( NULL, exec, autolock );
621
622 return retval;
623}
624
625#endif /* MLISP_DUMP_ENABLED */
626
627/* === */
628
629struct MLISP_ENV_NODE* mlisp_env_get(
630 struct MLISP_EXEC_STATE* exec, const char* key
631) {
632 struct MLISP_ENV_NODE* e = NULL;
633 struct MDATA_TABLE* env = NULL;
634 MERROR_RETVAL retval = MERROR_OK;
635 int8_t env_iter = exec->env_select;
636
637 while( 0 <= env_iter ) {
638 env = &(exec->env[env_iter]);
639
640 /* At the very least, the caller using this should be in the same lock
641 * context as this search, since we're returning a pointer. So no
642 * autolock!
643 */
644 assert( mdata_table_is_locked( env ) );
645
646 e = mdata_table_get( env, key, struct MLISP_ENV_NODE );
647 if( NULL != e ) {
648 /* Found something, so short-circuit! */
649 goto cleanup;
650 }
651
652 /* Try a higher frame. */
653 env_iter--;
654 }
655
656 /* Did not find anything in the local env, so try the global env if there
657 * is one!
658 */
659 if( NULL != exec->global_env ) {
660 assert( mdata_table_is_locked( exec->global_env ) );
661 e = mdata_table_get( exec->global_env, key, struct MLISP_ENV_NODE );
662 }
663
664cleanup:
665
666 if( MERROR_OK != retval ) {
667 e = NULL;
668 }
669
670 return e;
671}
672
673/* === */
674
675MERROR_RETVAL mlisp_env_unset(
676 struct MLISP_EXEC_STATE* exec, const char* token, size_t token_sz,
677 uint8_t global
678) {
679 MERROR_RETVAL retval = MERROR_OK;
680 uint8_t autolock[MLISP_EXEC_ENV_FRAME_CT_MAX];
681 int8_t env_iter = exec->env_select;
682 struct MDATA_TABLE* env = NULL;
683
684 /* TODO: Unset in global env if requested. */
685
686 maug_mzero( autolock, MLISP_EXEC_ENV_FRAME_CT_MAX );
687
688 while( 0 <= env_iter ) {
689#if MLISP_ENV_TRACE_LVL > 0
690 debug_printf( MLISP_ENV_TRACE_LVL,
691 "%u: attempting to undefine %s in frame %d...",
692 exec->uid, token, env_iter );
693#endif /* MLISP_ENV_TRACE_LVL */
694
695 env = &(exec->env[env_iter]);
696
697 if( !mdata_table_is_locked( env ) ) {
698 mdata_table_lock( env );
699 autolock[env_iter] |= 0x02;
700 }
701
702 retval = mdata_table_unset( env, token );
703
704 env_iter--;
705 }
706
707 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
708 if( 0x02 == (0x02 & autolock[env_iter]) ) {
709 env = &(exec->env[env_iter]);
710 assert( mdata_table_is_locked( env ) );
711 mdata_table_unlock( env );
712 }
713 }
714
715 return retval;
716}
717
718/* === */
719
720MERROR_RETVAL mlisp_env_set(
721 struct MLISP_EXEC_STATE* exec,
722 const char* token, size_t token_sz, uint8_t env_type, const void* data,
723 uint8_t global, uint8_t flags
724) {
725 MERROR_RETVAL retval = MERROR_OK;
726 struct MLISP_ENV_NODE e;
727 struct MDATA_TABLE* env = NULL;
728
729 /* Builtins can only be inserted into frame 0! */
730 assert(
731 (MLISP_ENV_FLAG_BUILTIN != (MLISP_ENV_FLAG_BUILTIN & flags)) ||
732 0 == exec->env_select );
733
734 /* Default to current local env frame, but switch to global if requested. */
735 env = &(exec->env[exec->env_select]);
736 if( global ) {
737 if( NULL != exec->global_env ) {
738 env = exec->global_env;
739 } else {
740 error_printf( "global env requested but not present!" );
741 retval = MERROR_EXEC;
742 goto cleanup;
743 }
744 }
745
746 if( 0 == token_sz ) {
747 token_sz = maug_strlen( token );
748 }
749
750 assert( NULL != env );
751 assert( 0 < token_sz );
752
753 assert( !mdata_table_is_locked( env ) );
754
755 /* Find previous env nodes with same token and change. */
756 /* Ignore the retval, since it doesn't really matter if this fails. */
757 mdata_table_unset( env, token );
758
759#if MLISP_ENV_TRACE_LVL > 0
760# define _MLISP_TYPE_TABLE_ASGN( idx, ctype, name, const_name, fmt ) \
761 case idx: \
762 debug_printf( MLISP_ENV_TRACE_LVL, \
763 "%u: setting env %d: \"%s\": #" fmt, \
764 exec->uid, exec->env_select, token, (ctype)*((ctype*)data) ); \
765 e.value.name = *((ctype*)data); \
766 break;
767#else
768# define _MLISP_TYPE_TABLE_ASGN( idx, ctype, name, const_name, fmt ) \
769 case idx: \
770 e.value.name = *((ctype*)data); \
771 break;
772#endif /* MLISP_ENV_TRACE_LVL */
773
774 /* Setup the new node to copy. */
775 maug_mzero( &e, sizeof( struct MLISP_ENV_NODE ) );
776 e.flags = flags;
777 maug_cleanup_if_not_ok();
778 e.type = env_type;
779 switch( env_type ) {
780 MLISP_NUM_TYPE_TABLE( _MLISP_TYPE_TABLE_ASGN );
781
782 /* Special cases: */
783
784 case 4 /* MLISP_TYPE_STR */:
785 /* TODO: Don't use strpool for this! */
786#if MLISP_ENV_TRACE_LVL > 0
787 debug_printf( MLISP_ENV_TRACE_LVL,
788 "%u: setting env %d: \"%s\": strpool(" SSIZE_T_FMT ")",
789 exec->uid, exec->env_select, token, *((ssize_t*)data) );
790#endif /* MLISP_ENV_TRACE_LVL */
791 e.value.strpool_idx = *((mdata_strpool_idx_t*)data);
792 break;
793
794 case 5 /* MLISP_TYPE_CB */:
795#if MLISP_ENV_TRACE_LVL > 0
796 debug_printf( MLISP_ENV_TRACE_LVL,
797 "%u: setting env %d: \"%s\": 0x%p",
798 exec->uid, exec->env_select, token, (mlisp_env_cb_t)data );
799#endif /* MLISP_ENV_TRACE_LVL */
800 e.value.cb = (mlisp_env_cb_t)data;
801 break;
802
803 case 6 /* MLISP_TYPE_LAMBDA */:
804#if MLISP_ENV_TRACE_LVL > 0
805 debug_printf( MLISP_ENV_TRACE_LVL,
806 "%u: setting env %d: \"%s\": node #" SSIZE_T_FMT,
807 exec->uid, exec->env_select, token, *((mlisp_lambda_t*)data) );
808#endif /* MLISP_ENV_TRACE_LVL */
809 e.value.lambda = *((mlisp_lambda_t*)data);
810 break;
811
812 case 10: /* MLISP_TYPE_BEGIN */
813 /* We probably called a lambda that takes an arg without placing an
814 * arg on the stack for it to take up!
815 *
816 * This could be a script error, but it could also be a lambda being
817 * itered into after its finished executing (and thus has no arg on the
818 * stack waiting for it).
819 *
820 * MERROR_RESET signals the calling program we're embedded in to deal
821 * with this situation, maybe by restarting the script with a fresh env.
822 */
823 error_printf(
824 "%u: underflow %s: missing lambda arg?",
825 exec->uid, token );
826 retval = MERROR_RESET;
827 goto cleanup;
828
829 default:
830 error_printf( "invalid type: %d", env_type );
831 retval = MERROR_EXEC;
832 goto cleanup;
833 }
834
835 retval = mdata_table_set( env, token, &e, sizeof( struct MLISP_ENV_NODE ) );
836
837cleanup:
838
839 return retval;
840}
841
842/* === */
843
844static MERROR_RETVAL _mlisp_env_cb_cmp(
845 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, size_t n_idx,
846 size_t args_c, void* cb_data, uint8_t flags
847) {
848 MERROR_RETVAL retval = MERROR_OK;
849 struct MLISP_STACK_NODE tmp;
850 uint8_t truth = 0;
851
852 /* The compiler seems to get a bit too eager if optimization is turned on,
853 * and ends up flubbing the comparison if these aren't volatile.
854 */
855 volatile int a_int,
856 b_int,
857 a_type,
858 b_type;
859 volatile int* cur_int = NULL;
860
861 mdata_strpool_lock( &(parser->strpool) );
862
863 /* XXX: If we put a mutable variable first, it gets modified? */
864
865#if MLISP_EXEC_TRACE_LVL > 0
866# define _MLISP_TYPE_TABLE_CMP( idx, ctype, name, const_name, fmt ) \
867 } else if( MLISP_TYPE_ ## const_name == tmp.type ) { \
868 *cur_int = (int)tmp.value.name; \
869 debug_printf( MLISP_EXEC_TRACE_LVL, \
870 "%u: cmp: pop " fmt " (%d)", exec->uid, tmp.value.name, *cur_int );
871#else
872# define _MLISP_TYPE_TABLE_CMP( idx, ctype, name, const_name, fmt ) \
873 } else if( MLISP_TYPE_ ## const_name == tmp.type ) { \
874 *cur_int = (int)tmp.value.name;
875#endif /* MLISP_EXEC_TRACE_LVL */
876
877 retval = mlisp_stack_pop( exec, &tmp );
878 maug_cleanup_if_not_ok();
879 cur_int = &b_int;
880 if( MLISP_TYPE_STR == tmp.type ) {
881 /* TODO: Buffer string for later comparison. */
882 a_type = MLISP_TYPE_STR;
883
884 MLISP_NUM_TYPE_TABLE( _MLISP_TYPE_TABLE_CMP )
885 } else {
886 error_printf( "cmp: invalid type: %d", tmp.type );
887 retval = MERROR_EXEC;
888 goto cleanup;
889 }
890
891 retval = mlisp_stack_pop( exec, &tmp );
892 maug_cleanup_if_not_ok();
893 cur_int = &a_int;
894 if( MLISP_TYPE_STR == tmp.type ) {
895 /* TODO: Buffer string for later comparison. */
896 b_type = MLISP_TYPE_STR;
897
898 MLISP_NUM_TYPE_TABLE( _MLISP_TYPE_TABLE_CMP )
899 } else {
900 error_printf( "cmp: invalid type!" );
901 retval = MERROR_EXEC;
902 goto cleanup;
903 }
904
905 /* TODO: String comparison? */
906 if( MLISP_TYPE_STR == a_type || MLISP_TYPE_STR == b_type ) {
907
908 /* TODO: Do a strncmp() and push 1 if true. */
909 retval = mlisp_stack_push( exec, 0, mlisp_bool_t );
910 goto cleanup;
911 }
912
913 /* String comparison didn't catch, so it must be a number comparison? */
915#if MLISP_EXEC_TRACE_LVL > 0
916 debug_printf( MLISP_EXEC_TRACE_LVL, "%u: cmp %d > %d",
917 exec->uid, a_int, b_int );
918#endif /* MLISP_EXEC_TRACE_LVL */
919 truth = a_int > b_int;
920 } else if( MLISP_ENV_FLAG_CMP_LT == (MLISP_ENV_FLAG_CMP_LT & flags) ) {
921#if MLISP_EXEC_TRACE_LVL > 0
922 debug_printf( MLISP_EXEC_TRACE_LVL, "%u: cmp %d < %d",
923 exec->uid, a_int, b_int );
924#endif /* MLISP_EXEC_TRACE_LVL */
925 truth = a_int < b_int;
926 } else if( MLISP_ENV_FLAG_CMP_EQ == (MLISP_ENV_FLAG_CMP_EQ & flags) ) {
927#if MLISP_EXEC_TRACE_LVL > 0
928 debug_printf( MLISP_EXEC_TRACE_LVL, "%u: cmp %d == %d",
929 exec->uid, a_int, b_int );
930#endif /* MLISP_EXEC_TRACE_LVL */
931 truth = a_int == b_int;
932 } else {
933 error_printf( "invalid parameter provided to _mlisp_env_cb_cmp()!" );
934 retval = MERROR_EXEC;
935 goto cleanup;
936 }
937
938 retval = mlisp_stack_push( exec, truth, mlisp_bool_t );
939
940cleanup:
941
942 mdata_strpool_unlock( &(parser->strpool) );
943
944 return retval;
945}
946
947/* === */
948
949static MERROR_RETVAL _mlisp_env_cb_arithmetic(
950 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, size_t n_idx,
951 size_t args_c, void* cb_data, uint8_t flags
952) {
953 MERROR_RETVAL retval = MERROR_OK;
954 struct MLISP_STACK_NODE num;
955 /* TODO: Vary type based on multiplied types. */
956 int16_t num_out = 0;
957 size_t i = 0;
958
959# define _MLISP_TYPE_TABLE_ARI1( idx, ctype, name, const_name, fmt ) \
960 } else if( MLISP_TYPE_ ## const_name == num.type ) { \
961 num_out = num.value.name;
962
963 retval = mlisp_stack_pop( exec, &num );
964 maug_cleanup_if_not_ok();
965
966 if( 0 ) {
967 MLISP_NUM_TYPE_TABLE( _MLISP_TYPE_TABLE_ARI1 )
968 } else {
969 error_printf( "arithmetic: invalid type!" );
970 retval = MERROR_EXEC;
971 goto cleanup;
972 }
973
974# define _MLISP_TYPE_TABLE_ARI2( idx, ctype, name, const_name, fmt ) \
975 } else if( \
976 MLISP_TYPE_ ## const_name == num.type && \
977 MLISP_ENV_FLAG_ARI_ADD == (MLISP_ENV_FLAG_ARI_ADD & flags) \
978 ) { \
979 debug_printf( MLISP_EXEC_TRACE_LVL, \
980 "%u: arithmetic: %d + " fmt, exec->uid, num_out, num.value.name ); \
981 num_out += num.value.name; \
982 } else if( \
983 MLISP_TYPE_ ## const_name == num.type && \
984 MLISP_ENV_FLAG_ARI_MUL == (MLISP_ENV_FLAG_ARI_MUL & flags) \
985 ) { \
986 debug_printf( MLISP_EXEC_TRACE_LVL, \
987 "%u: arithmetic: %d * " fmt, exec->uid, num_out, num.value.name ); \
988 num_out *= num.value.name; \
989 } else if( \
990 MLISP_TYPE_ ## const_name == num.type && \
991 MLISP_ENV_FLAG_ARI_DIV == (MLISP_ENV_FLAG_ARI_DIV & flags) \
992 ) { \
993 debug_printf( MLISP_EXEC_TRACE_LVL, \
994 "%u: arithmetic: %d / " fmt, exec->uid, num_out, num.value.name ); \
995 num_out /= num.value.name; \
996
997 for( i = 0 ; args_c - 1 > i ; i++ ) {
998 retval = mlisp_stack_pop( exec, &num );
999 maug_cleanup_if_not_ok();
1000
1001 if( 0 ) {
1002 MLISP_NUM_TYPE_TABLE( _MLISP_TYPE_TABLE_ARI2 )
1003
1004 } else if(
1005 MLISP_TYPE_INT == num.type &&
1006 MLISP_ENV_FLAG_ARI_MOD == (MLISP_ENV_FLAG_ARI_MOD & flags)
1007 ) {
1008 /* Modulus is a special case, as you can't mod by float. */
1009 debug_printf( MLISP_EXEC_TRACE_LVL,
1010 "%u: arithmetic: %d %% %d", exec->uid, num_out, num.value.integer );
1011 num_out %= num.value.integer;
1012 } else {
1013 error_printf( "arithmetic: invalid type!" );
1014 retval = MERROR_EXEC;
1015 goto cleanup;
1016 }
1017 }
1018
1019 debug_printf( MLISP_EXEC_TRACE_LVL,
1020 "%u: arithmetic result: %d", exec->uid, num_out );
1021
1022 retval = mlisp_stack_push( exec, num_out, int16_t );
1023
1024cleanup:
1025
1026 mdata_strpool_unlock( &(parser->strpool) );
1027
1028 return retval;
1029}
1030
1031/* === */
1032
1033static MERROR_RETVAL _mlisp_env_cb_debug(
1034 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, size_t n_idx,
1035 size_t args_c, void* cb_data, uint8_t flags
1036) {
1037 MERROR_RETVAL retval = MERROR_OK;
1038 struct MLISP_STACK_NODE val;
1039
1040 retval = mlisp_stack_pop( exec, &val );
1041 maug_cleanup_if_not_ok();
1042
1043# define _MLISP_TYPE_TABLE_DBG( idx, ctype, name, const_name, fmt ) \
1044 } else if( idx == val.type ) { \
1045 debug_printf( 2, fmt, val.value.name ); \
1046
1047 if( MLISP_TYPE_STR == val.type ) {
1048 debug_printf( 2, "%s", mdata_strpool_extract(
1049 &(parser->strpool), val.value.strpool_idx ) );
1050 MLISP_NUM_TYPE_TABLE( _MLISP_TYPE_TABLE_DBG )
1051 }
1052
1053cleanup:
1054
1055 return retval;
1056}
1057
1058/* === */
1059
1060static MERROR_RETVAL _mlisp_env_cb_define(
1061 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, size_t n_idx,
1062 size_t args_c, void* cb_data, uint8_t flags
1063) {
1064 MERROR_RETVAL retval = MERROR_OK;
1065 struct MLISP_STACK_NODE key;
1066 struct MLISP_STACK_NODE val;
1067 MAUG_MHANDLE key_tmp_h = (MAUG_MHANDLE)NULL;
1068 char* key_tmp = NULL;
1069 uint8_t global = 0;
1070
1071#if MLISP_EXEC_TRACE_LVL > 0
1072 debug_printf( MLISP_EXEC_TRACE_LVL, "%u: entering define callback...",
1073 exec->uid );
1074#endif /* MLISP_EXEC_TRACE_LVL */
1075
1076 retval = mlisp_stack_pop( exec, &val );
1077 maug_cleanup_if_not_ok();
1078
1079 retval = mlisp_stack_pop( exec, &key );
1080 maug_cleanup_if_not_ok();
1081
1082 if( MLISP_TYPE_STR != key.type ) {
1083 /* TODO: Do we want to allow defining other types? */
1084 /* TODO: We can use _mlisp_eval_token_strpool, maybe? */
1085 error_printf( "define: invalid key type: %d", key.type );
1086 retval = MERROR_EXEC;
1087 goto cleanup;
1088 }
1089
1090#if MLISP_EXEC_TRACE_LVL > 0
1091 debug_printf( MLISP_EXEC_TRACE_LVL,
1092 "%u: extracting define term for idx: " SIZE_T_FMT,
1093 exec->uid, key.value.strpool_idx );
1094#endif /* MLISP_EXEC_TRACE_LVL */
1095
1096 key_tmp_h = mdata_strpool_extract(
1097 &(parser->strpool), key.value.strpool_idx );
1098 /* TODO: Handle this gracefully. */
1099 assert( (MAUG_MHANDLE)NULL != key_tmp_h );
1100
1101 maug_mlock( key_tmp_h, key_tmp );
1102 maug_cleanup_if_null_lock( char*, key_tmp );
1103
1104#if MLISP_EXEC_TRACE_LVL > 0
1105 debug_printf( MLISP_EXEC_TRACE_LVL,
1106 "%u: define \"%s\" (strpool(" SIZE_T_FMT "))...",
1107 exec->uid, key_tmp, key.value.strpool_idx );
1108#endif /* MLISP_EXEC_TRACE_LVL */
1109
1110 /* Figure out the env to use. */
1111 if(
1113 ) {
1114#if MLISP_EXEC_TRACE_LVL > 0
1115 debug_printf( MLISP_EXEC_TRACE_LVL,
1116 "%u: using global env...", exec->uid );
1117#endif /* MLISP_EXEC_TRACE_LVL */
1118 global = 1;
1119 }
1120
1121 /* Perform the insertion. */
1122 retval = mlisp_env_set(
1123 exec, key_tmp, maug_strlen( key_tmp ), val.type, &(val.value),
1124 global, 0 );
1125 maug_cleanup_if_not_ok();
1126
1127#if MLISP_EXEC_TRACE_LVL > 0
1128 debug_printf( MLISP_EXEC_TRACE_LVL,
1129 "%u: setup env node: %s",
1130 exec->uid, key_tmp );
1131#endif /* MLISP_EXEC_TRACE_LVL */
1132
1133cleanup:
1134
1135 if( NULL != key_tmp ) {
1136 maug_munlock( key_tmp_h, key_tmp );
1137 }
1138
1139 if( (MAUG_MHANDLE)NULL != key_tmp_h ) {
1140 maug_mfree( key_tmp_h );
1141 }
1142
1143 return retval;
1144}
1145
1146/* === */
1147
1148static MERROR_RETVAL _mlisp_env_cb_if(
1149 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, size_t n_idx,
1150 size_t args_c, void* cb_data, uint8_t flags
1151) {
1152 MERROR_RETVAL retval = MERROR_OK;
1153 size_t* p_if_child_idx = NULL;
1154 struct MLISP_STACK_NODE s;
1155 struct MLISP_AST_NODE* n = NULL;
1156
1157#if MLISP_STEP_TRACE_LVL > 0
1158 debug_printf( MLISP_STEP_TRACE_LVL,
1159 "%u: qrqrqrqrqr STEP IF qrqrqrqrqr", exec->uid );
1160#endif /* MLISP_STEP_TRACE_LVL */
1161
1162 /* Grab the current exec index for the child vector for this node. */
1163 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1164 p_if_child_idx = mdata_vector_get(
1165 &(exec->per_node_child_idx), n_idx, size_t );
1166 assert( NULL != p_if_child_idx );
1167#if MLISP_STEP_TRACE_LVL > 0
1168 debug_printf( MLISP_STEP_TRACE_LVL,
1169 "%u: node " SIZE_T_FMT " child idx: " SIZE_T_FMT,
1170 exec->uid, n_idx, *p_if_child_idx );
1171#endif /* MLISP_STEP_TRACE_LVL */
1172
1173 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1174
1175 if( 0 == *p_if_child_idx ) {
1176 /* Evaluating if condition. */
1177#if MLISP_STEP_TRACE_LVL > 0
1178 debug_printf( MLISP_STEP_TRACE_LVL,
1179 "%u: stepping into condition...", exec->uid );
1180#endif /* MLISP_STEP_TRACE_LVL */
1181 retval = _mlisp_step_iter(
1182 parser, n->ast_idx_children[*p_if_child_idx], exec );
1183#if MLISP_STEP_TRACE_LVL > 0
1184 debug_printf( MLISP_STEP_TRACE_LVL,
1185 "%u: ...stepped out of condition", exec->uid );
1186#endif /* MLISP_STEP_TRACE_LVL */
1187
1188 /* Vary the child we jump to based on the boolean val on the stack. */
1189 if( MERROR_OK == retval ) {
1190 /* Condition evaluation complete. */
1191
1192 /* Pop the result and check it. */
1193 retval = mlisp_stack_pop( exec, &s );
1194 maug_cleanup_if_not_ok();
1195 if( MLISP_TYPE_BOOLEAN != s.type ) {
1196 error_printf( "(if) can only evaluate boolean type!" );
1197 retval = MERROR_EXEC;
1198 goto cleanup;
1199 }
1200
1201 /* Set the child pointer to 1 if TRUE and 2 if FALSE. */
1202 retval = _mlisp_preempt(
1203 retval, "if", parser, n_idx, exec,
1204 /* Flip boolean and increment. */
1205 (1 - s.value.boolean) + 1 );
1206 }
1207
1208 } else if( args_c > *p_if_child_idx ) { /* 3 if else present, else 2. */
1209 /* Pursuing TRUE or FALSE clause. */
1210
1211#if MLISP_STEP_TRACE_LVL > 0
1212 debug_printf( MLISP_STEP_TRACE_LVL,
1213 "%u: descending into IF path: " SIZE_T_FMT,
1214 exec->uid, *p_if_child_idx );
1215#endif /* MLISP_STEP_TRACE_LVL */
1216
1217 /* Prepare for stepping. */
1218
1219 /* Step and check. */
1220 retval = _mlisp_step_iter(
1221 parser, n->ast_idx_children[*p_if_child_idx], exec );
1222 retval = _mlisp_preempt(
1223 retval, "if", parser, n_idx, exec, 3 );
1224 }
1225
1226cleanup:
1227
1228#if MLISP_STEP_TRACE_LVL > 0
1229 debug_printf( MLISP_STEP_TRACE_LVL,
1230 "%u: qrqrqrqrqr END STEP IF qrqrqrqrqr", exec->uid );
1231#endif /* MLISP_STEP_TRACE_LVL */
1232
1233 return retval;
1234}
1235
1236/* === */
1237
1238#ifndef MAUG_NO_RETRO
1239/* TODO: Define this callback in retroflat in line with dependency guidelines.
1240 */
1241
1242static MERROR_RETVAL _mlisp_env_cb_random(
1243 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, size_t n_idx,
1244 size_t args_c, void* cb_data, uint8_t flags
1245) {
1246 MERROR_RETVAL retval = MERROR_OK;
1247 struct MLISP_STACK_NODE mod;
1248 int16_t random_int = 0;
1249
1250 retval = mlisp_stack_pop( exec, &mod );
1251 maug_cleanup_if_not_ok();
1252
1253 if( MLISP_TYPE_INT != mod.type ) {
1254 /* TODO: Setup float. */
1255 error_printf( "random: invalid modulus type: %d", mod.type );
1256 retval = MERROR_EXEC;
1257 goto cleanup;
1258 }
1259
1260 random_int = retroflat_get_rand() % mod.value.integer;
1261
1262#if MLISP_EXEC_TRACE_LVL > 0
1263 debug_printf( MLISP_EXEC_TRACE_LVL,
1264 "%u: random: %d", exec->uid, random_int );
1265#endif /* MLISP_EXEC_TRACE_LVL */
1266
1267 mlisp_stack_push( exec, random_int, int16_t );
1268
1269cleanup:
1270
1271 return retval;
1272}
1273
1274#endif /* !MAUG_NO_RETRO */
1275
1276/* === */
1277
1278static MERROR_RETVAL _mlisp_env_cb_ano(
1279 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, size_t n_idx,
1280 size_t args_c, void* cb_data, uint8_t flags
1281) {
1282 MERROR_RETVAL retval = MERROR_OK;
1283 struct MLISP_STACK_NODE val;
1284 mlisp_bool_t val_out =
1285 /* Default to false for OR or true for AND. */
1286 MLISP_ENV_FLAG_ANO_OR == (MLISP_ENV_FLAG_ANO_OR & flags) ?
1287 0 : 1;
1288 size_t i = 0;
1289
1290 /* TODO: Switch this to a step_or() function so that we can opt not to
1291 * evaluate conditions unless prior stepped children are false.
1292 */
1293
1294 for( i = 0 ; args_c > i ; i++ ) {
1295 retval = mlisp_stack_pop( exec, &val );
1296 maug_cleanup_if_not_ok();
1297
1298 if( MLISP_TYPE_BOOLEAN != val.type ) {
1299 error_printf( "or: invalid boolean type: %d", val.type );
1300 }
1301
1302 if(
1303 MLISP_ENV_FLAG_ANO_OR == (MLISP_ENV_FLAG_ANO_OR & flags) &&
1304 val.value.boolean
1305 ) {
1306#if MLISP_CMP_TRACE_LVL > 0
1307 debug_printf( MLISP_CMP_TRACE_LVL, "%u: found TRUE in OR compare!",
1308 exec->uid );
1309#endif /* MLISP_CMP_TRACE_LVL */
1310 val_out = 1;
1311 break;
1312 } else if(
1313 MLISP_ENV_FLAG_ANO_AND == (MLISP_ENV_FLAG_ANO_AND & flags) &&
1314 !val.value.boolean
1315 ) {
1316#if MLISP_CMP_TRACE_LVL > 0
1317 debug_printf( MLISP_CMP_TRACE_LVL, "%u: found FALSE in AND compare!",
1318 exec->uid );
1319#endif /* MLISP_CMP_TRACE_LVL */
1320 val_out = 0;
1321 break;
1322 }
1323 }
1324
1325#if MLISP_CMP_TRACE_LVL > 0
1326 debug_printf( MLISP_CMP_TRACE_LVL, "compare result: %d", val_out );
1327#endif /* MLISP_CMP_TRACE_LVL */
1328 retval = _mlisp_stack_push_mlisp_bool_t( exec, val_out );
1329
1330cleanup:
1331
1332 return retval;
1333}
1334
1335/* === */
1336
1337/* Execution Functions */
1338
1339/* === */
1340
1341static MERROR_RETVAL _mlisp_preempt(
1342 MERROR_RETVAL retval, const char* caller, struct MLISP_PARSER* parser,
1343 size_t n_idx, struct MLISP_EXEC_STATE* exec, size_t new_idx
1344) {
1345 struct MLISP_AST_NODE* n = NULL;
1346 size_t* p_child_idx = NULL;
1347
1348 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1349 p_child_idx = mdata_vector_get(
1350 &(exec->per_node_child_idx), n_idx, size_t );
1351 assert( NULL != p_child_idx );
1352
1353 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1354
1355 if( 0 < n->token_idx ) {
1356 mdata_strpool_lock( &(parser->strpool) );
1357#if MLISP_STEP_TRACE_LVL > 0
1358 debug_printf( MLISP_STEP_TRACE_LVL,
1359 "%u: eval step " SSIZE_T_FMT " under (%s) %s...",
1360 exec->uid, *p_child_idx, caller,
1361 mdata_strpool_get( &(parser->strpool), n->token_idx ) );
1362#endif /* MLISP_STEP_TRACE_LVL */
1363 mdata_strpool_unlock( &(parser->strpool) );
1364#if MLISP_STEP_TRACE_LVL > 0
1365 } else {
1366 debug_printf( MLISP_STEP_TRACE_LVL,
1367 "%u: eval step " SSIZE_T_FMT " under (%s) (empty token)...",
1368 exec->uid, *p_child_idx, caller );
1369#endif /* MLISP_STEP_TRACE_LVL */
1370 }
1371
1372 if( MERROR_OK != retval ) {
1373 /* Something bad happened, so don't increment! */
1374#if MLISP_STEP_TRACE_LVL > 0
1375 debug_printf( MLISP_STEP_TRACE_LVL,
1376 "%u: not incrementing node " SIZE_T_FMT " child idx from "
1377 SIZE_T_FMT " (retval: 0x%x)!",
1378 exec->uid, n_idx, *p_child_idx, retval );
1379#endif /* MLISP_STEP_TRACE_LVL */
1380 goto cleanup;
1381 }
1382
1383 /* Could not exec *this* node yet, so don't increment its parent. */
1384 retval = MERROR_PREEMPT;
1385
1386 /* Increment this node, since the child actually executed. */
1387 (*p_child_idx) = new_idx;
1388#if MLISP_STEP_TRACE_LVL > 0
1389 debug_printf( MLISP_STEP_TRACE_LVL,
1390 "%u: incremented node " SIZE_T_FMT " child idx to: " SIZE_T_FMT,
1391 exec->uid, n_idx, *p_child_idx );
1392#endif /* MLISP_STEP_TRACE_LVL */
1393
1394cleanup:
1395
1396 assert( !mdata_strpool_is_locked( &(parser->strpool) ) );
1397
1398 return retval;
1399}
1400
1401/* === */
1402
1403static MERROR_RETVAL _mlisp_step_iter_children(
1404 struct MLISP_PARSER* parser, size_t n_idx, struct MLISP_EXEC_STATE* exec
1405) {
1406 MERROR_RETVAL retval = MERROR_OK;
1407 size_t* p_child_idx = NULL;
1408 struct MLISP_AST_NODE* n = NULL;
1409
1410 /* Grab the current exec index for the child vector for this node. */
1411 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1412 p_child_idx = mdata_vector_get(
1413 &(exec->per_node_child_idx), n_idx, size_t );
1414 assert( NULL != p_child_idx );
1415#if MLISP_STEP_TRACE_LVL > 0
1416 debug_printf( MLISP_STEP_TRACE_LVL,
1417 "%u: node " SIZE_T_FMT " child idx: " SIZE_T_FMT,
1418 exec->uid, n_idx, *p_child_idx );
1419#endif /* MLISP_STEP_TRACE_LVL */
1420
1421 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1422
1423 if(
1424 (
1425 MLISP_AST_FLAG_LAMBDA == (MLISP_AST_FLAG_LAMBDA & n->flags) &&
1426 0 == *p_child_idx
1427 ) ||
1428 MLISP_AST_FLAG_IF == (MLISP_AST_FLAG_IF & n->flags)
1429 ) {
1430 /* A lambda definition was found, and its exec counter is still pointing
1431 * to the arg list. This means the lambda was *not* called on the last
1432 * heartbeat, and we're probably just enountering its definition.
1433 *
1434 * Lambdas are lazily evaluated, so don't pursue it further until it's
1435 * called (stee _mlisp_step_lambda() for more info on this.
1436 */
1437#if MLISP_STEP_TRACE_LVL > 0
1438 debug_printf( MLISP_STEP_TRACE_LVL,
1439 "%u: skipping lambda children...", exec->uid );
1440#endif /* MLISP_STEP_TRACE_LVL */
1441 goto cleanup;
1442 }
1443
1444 if( mlisp_ast_has_ready_children( *p_child_idx, n ) ) {
1445 /* Call the next uncalled child. */
1446
1447 if(
1448 MLISP_AST_FLAG_DEFINE == (MLISP_AST_FLAG_DEFINE & n->flags) &&
1449 0 == *p_child_idx
1450 ) {
1451 /* The next child is a term to be defined. */
1452#if MLISP_EXEC_TRACE_LVL > 0
1453 debug_printf( MLISP_EXEC_TRACE_LVL,
1454 "%u: setting MLISP_EXEC_FLAG_DEF_TERM!", exec->uid );
1455#endif /* MLISP_EXEC_TRACE_LVL */
1457 } else {
1458 exec->flags &= ~MLISP_EXEC_FLAG_DEF_TERM;
1459 }
1460
1461 /* Step and check. */
1462 retval = _mlisp_step_iter(
1463 parser, n->ast_idx_children[*p_child_idx], exec );
1464 retval = _mlisp_preempt(
1465 retval, "node", parser, n_idx, exec, (*p_child_idx) + 1 );
1466 goto cleanup;
1467 }
1468
1469cleanup:
1470
1471 return retval;
1472}
1473
1474/* === */
1475
1476static MERROR_RETVAL _mlisp_step_lambda_args(
1477 struct MLISP_PARSER* parser, size_t n_idx, struct MLISP_EXEC_STATE* exec
1478) {
1479 MERROR_RETVAL retval = MERROR_OK;
1480 ssize_t arg_idx = 0;
1481 struct MLISP_STACK_NODE stack_n_arg;
1482 struct MLISP_AST_NODE* ast_n_arg = NULL;
1483 MAUG_MHANDLE key_tmp_h = (MAUG_MHANDLE)NULL;
1484 char* key_tmp = NULL;
1485 struct MLISP_AST_NODE* n = NULL;
1486 int16_t null_val = 0;
1487
1488 /* Pop stack into args into the env. These are all the results of previous
1489 * evaluations, before the lambda call, so we can just grab them all in
1490 * one go!
1491 */
1492
1493 /* Create a new env and bump up env_select. */
1494 if( MLISP_EXEC_ENV_FRAME_CT_MAX > exec->env_select + 1 ) {
1495 exec->env_select++;
1496#if MLISP_EXEC_TRACE_LVL > 0
1497 debug_printf( MLISP_EXEC_TRACE_LVL, "selecting env frame: %d",
1498 exec->env_select );
1499#endif /* MLISP_EXEC_TRACE_LVL */
1500 assert( 0 == mdata_table_ct( &(exec->env[exec->env_select]) ) );
1501
1502 /* Toss a constant into the new env so it's not as wonky. */
1503 retval = mlisp_env_set(
1504 exec, "null", 4, MLISP_TYPE_INT, &null_val, 0, 0 );
1505 } else {
1506 error_printf( "env frame overflow!" );
1507 retval = MERROR_OVERFLOW;
1508 goto cleanup;
1509 }
1510
1511 /* Get the current args node. */
1512 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1513 arg_idx = n->ast_idx_children_sz - 1;
1514
1515 while( 0 <= arg_idx ) {
1516
1517 retval = mlisp_stack_pop( exec, &stack_n_arg );
1518 maug_cleanup_if_not_ok();
1519
1520 ast_n_arg = mdata_vector_get(
1521 &(parser->ast), n->ast_idx_children[arg_idx],
1522 struct MLISP_AST_NODE );
1523
1524 /* Pull out the arg name from the strpool so we can call env_set(). */
1525 key_tmp_h = mdata_strpool_extract(
1526 &(parser->strpool), ast_n_arg->token_idx );
1527 /* TODO: Handle this gracefully. */
1528 assert( (MAUG_MHANDLE)NULL != key_tmp_h );
1529
1530 maug_mlock( key_tmp_h, key_tmp );
1531 maug_cleanup_if_null_lock( char*, key_tmp );
1532
1533 retval = mlisp_env_set(
1534 exec, key_tmp, 0, stack_n_arg.type, &(stack_n_arg.value), 0, 0 );
1535 maug_cleanup_if_not_ok();
1536
1537 maug_munlock( key_tmp_h, key_tmp );
1538 maug_mfree( key_tmp_h );
1539
1540 arg_idx--;
1541 }
1542
1543cleanup:
1544
1545 if( NULL != key_tmp ) {
1546 maug_munlock( key_tmp_h, key_tmp );
1547 }
1548
1549 if( (MAUG_MHANDLE)NULL != key_tmp_h ) {
1550 maug_mfree( key_tmp_h );
1551 }
1552
1553 return retval;
1554}
1555
1556/* === */
1557
1558static MERROR_RETVAL _mlisp_reset_child_pcs(
1559 const struct MLISP_PARSER* parser,
1560 size_t n_idx, struct MLISP_EXEC_STATE* exec
1561) {
1562 MERROR_RETVAL retval = MERROR_OK;
1563 size_t* p_child_idx = NULL;
1564 size_t* p_visit_ct = NULL;
1565 struct MLISP_AST_NODE* n = NULL;
1566 size_t i = 0;
1567
1568 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1569 assert( mdata_vector_is_locked( &(parser->ast) ) );
1570
1571 /* Perform the actual reset. */
1572#if MLISP_STEP_TRACE_LVL > 0
1573 debug_printf( MLISP_STEP_TRACE_LVL,
1574 "%u: resetting node " SIZE_T_FMT " child idx to 0", exec->uid, n_idx );
1575#endif /* MLISP_STEP_TRACE_LVL */
1576 p_child_idx = mdata_vector_get( &(exec->per_node_child_idx), n_idx, size_t );
1577 assert( NULL != p_child_idx );
1578 *p_child_idx = 0;
1579
1580#if MLISP_STEP_TRACE_LVL > 0
1581 debug_printf( MLISP_STEP_TRACE_LVL,
1582 "%u: resetting node " SIZE_T_FMT " visit count to 0", exec->uid, n_idx );
1583#endif /* MLISP_STEP_TRACE_LVL */
1584 p_visit_ct = mdata_vector_get( &(exec->per_node_visit_ct), n_idx, size_t );
1585 assert( NULL != p_visit_ct );
1586 *p_visit_ct = 0;
1587
1588 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1589
1590 /* Call reset on all children. */
1591 for( i = 0 ; n->ast_idx_children_sz > i ; i++ ) {
1592 retval = _mlisp_reset_child_pcs( parser, n->ast_idx_children[i], exec );
1593 maug_cleanup_if_not_ok();
1594 }
1595
1596cleanup:
1597
1598 return retval;
1599}
1600
1601/* === */
1602
1603static MERROR_RETVAL _mlisp_reset_lambda(
1604 const struct MLISP_PARSER* parser,
1605 size_t n_idx, struct MLISP_EXEC_STATE* exec
1606) {
1607 MERROR_RETVAL retval = MERROR_OK;
1608
1609#if MLISP_EXEC_TRACE_LVL > 0
1610 debug_printf( MLISP_EXEC_TRACE_LVL,
1611 "%u: resetting lambda " SIZE_T_FMT "...", exec->uid, n_idx );
1612#endif /* MLISP_EXEC_TRACE_LVL */
1613
1614 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1615
1616 /* Move up one env frame. */
1617 assert( !mdata_table_is_locked( &(exec->env[exec->env_select]) ) );
1618 assert( 0 < exec->env_select );
1619 mdata_table_free( &(exec->env[exec->env_select]) );
1620 exec->env_select--;
1621
1622 /* Reset per-node program counters. */
1623 retval = _mlisp_reset_child_pcs( parser, n_idx, exec );
1624
1625 return retval;
1626}
1627
1628/* === */
1629
1630/* This is internal-only and should only be called from _mlisp_step_iter()! */
1631static MERROR_RETVAL _mlisp_step_lambda(
1632 struct MLISP_PARSER* parser,
1633 size_t n_idx, struct MLISP_EXEC_STATE* exec
1634) {
1635 MERROR_RETVAL retval = MERROR_OK;
1636 size_t* p_lambda_child_idx = NULL;
1637#if MLISP_STEP_TRACE_LVL > 0
1638 size_t* p_args_child_idx = NULL;
1639#endif /* MLISP_STEP_TRACE_LVL */
1640 struct MLISP_AST_NODE* n = NULL;
1641 size_t* p_n_last_lambda = NULL;
1642 ssize_t append_retval = 0;
1643
1644#ifdef MLISP_DEBUG_TRACE
1645 exec->trace[exec->trace_depth++] = n_idx;
1646 assert( exec->trace_depth <= MLISP_DEBUG_TRACE );
1647#endif /* MLISP_DEBUG_TRACE */
1648
1649 /* n_idx is the node of this lambda. */
1650 mdata_vector_lock( &(exec->lambda_trace) );
1651 p_n_last_lambda = mdata_vector_get_last( &(exec->lambda_trace), size_t );
1653 if( NULL != p_n_last_lambda && n_idx == *p_n_last_lambda ) {
1654 /* This is a recursive call, so get rid of the lambda context so we can
1655 * replace it with a new one afterwards.
1656 */
1657#if MLISP_STEP_TRACE_LVL > 0
1658 debug_printf( MLISP_STEP_TRACE_LVL, "%u: TRACE TAIL TIME!", exec->uid );
1659#endif /* MLISP_STEP_TRACE_LVL */
1660 /*
1661 assert(
1662 !mdata_table_is_locked( &(exec->env) ) );
1663 */
1664 _mlisp_reset_lambda( parser, n_idx, exec );
1665 retval = mdata_vector_remove_last( &(exec->lambda_trace) );
1666 maug_cleanup_if_not_ok();
1667 }
1668
1669#if MLISP_STEP_TRACE_LVL > 0
1670 debug_printf( MLISP_STEP_TRACE_LVL,
1671 "%u: xvxvxvxvxvxvx STEP LAMBDA " SIZE_T_FMT " xvxvxvxvxvx",
1672 exec->uid, n_idx );
1673#endif /* MLISP_STEP_TRACE_LVL */
1674
1675 /* Note that we passed through this lambda to detect tail calls later. */
1676 append_retval = mdata_vector_append(
1677 &(exec->lambda_trace), &n_idx, sizeof( size_t ) );
1678 retval = mdata_retval( append_retval );
1679 maug_cleanup_if_not_ok();
1680
1681 /* Grab the current exec index for the child vector for this node. */
1682 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1683 p_lambda_child_idx = mdata_vector_get(
1684 &(exec->per_node_child_idx), n_idx, size_t );
1685 assert( NULL != p_lambda_child_idx );
1686#if MLISP_STEP_TRACE_LVL > 0
1687 debug_printf( MLISP_STEP_TRACE_LVL,
1688 "%u: lambda node " SIZE_T_FMT " child idx: " SIZE_T_FMT,
1689 exec->uid, n_idx, *p_lambda_child_idx );
1690#endif /* MLISP_STEP_TRACE_LVL */
1691
1692 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1693
1694 /* There needs to be an arg node and an exec node. */
1695 /* TODO: Handle this gracefully. */
1696 assert( 1 < n->ast_idx_children_sz );
1697
1698 if( 0 == *p_lambda_child_idx ) {
1699 /* Parse the args passed to this lambda into the env, temporarily. */
1700
1701 /* Get the current args node child index. */
1702 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1703#if MLISP_STEP_TRACE_LVL > 0
1704 p_args_child_idx =
1705#endif /* MLISP_STEP_TRACE_LVL */
1706 mdata_vector_get(
1707 &(exec->per_node_child_idx),
1708 n->ast_idx_children[*p_lambda_child_idx], size_t );
1709#if MLISP_STEP_TRACE_LVL > 0
1710 assert( NULL != p_args_child_idx );
1711 debug_printf( MLISP_STEP_TRACE_LVL,
1712 "%u: child idx for args AST node " SIZE_T_FMT ": " SIZE_T_FMT,
1713 exec->uid, *p_lambda_child_idx, *p_args_child_idx );
1714#endif /* MLISP_STEP_TRACE_LVL */
1715
1716 /* Pop stack into args in the env. */
1717 retval = _mlisp_step_lambda_args(
1718 parser, n->ast_idx_children[*p_lambda_child_idx], exec );
1719 if( MERROR_OK != retval && MERROR_PREEMPT != retval ) {
1720 /* Something bad happened! */
1721 goto cleanup;
1722 }
1723
1724 if( MERROR_OK == retval ) {
1725 /* Set *after-arg* delimiter in env after last arg. */
1726 /*
1727 retval = mlisp_env_set(
1728 parser, exec, "$ARGS_E$", 0, MLISP_TYPE_ARGS_E, &n_idx, NULL, 0 );
1729 maug_cleanup_if_not_ok();
1730 */
1731
1732 /* Increment child idx so we call the exec child on next heartbeat. */
1733 (*p_lambda_child_idx)++;
1734#if MLISP_STEP_TRACE_LVL > 0
1735 debug_printf( MLISP_STEP_TRACE_LVL,
1736 "%u: incremented node " SIZE_T_FMT " child idx to: " SIZE_T_FMT,
1737 exec->uid, n_idx, *p_lambda_child_idx );
1738#endif /* MLISP_STEP_TRACE_LVL */
1739 }
1740
1741 /* Set the error to MERROR_PREEMPT so that caller knows this lambda isn't
1742 * finished executing.
1743 */
1744 retval = MERROR_PREEMPT;
1745
1746 } else if( mlisp_ast_has_ready_children( *p_lambda_child_idx, n ) ) {
1747 /* Dive into first lambda child until we no longer can. */
1748
1749 /*
1750 assert(
1751 !mdata_table_is_locked( &(exec->env) ) );
1752 */
1753 assert(
1754 NULL == exec->global_env ||
1755 !mdata_table_is_locked( exec->global_env ) );
1756
1757 retval = _mlisp_step_iter(
1758 parser, n->ast_idx_children[*p_lambda_child_idx], exec );
1759
1760 retval = _mlisp_preempt(
1761 retval, "lambda", parser, n_idx, exec, (*p_lambda_child_idx) + 1 );
1762
1763 } else {
1764 /* No more children to execute! */
1765 /* assert(
1766 !mdata_table_is_locked( &(exec->env) ) ); */
1767 assert(
1768 NULL == exec->global_env ||
1769 !mdata_table_is_locked( exec->global_env ) );
1770 _mlisp_reset_lambda( parser, n_idx, exec );
1771 }
1772
1773 /* TODO: If MERROR_PREEMPT is not returned, remove args_s and args_e? */
1774
1775cleanup:
1776
1777#if MLISP_STEP_TRACE_LVL > 0
1778 debug_printf( MLISP_STEP_TRACE_LVL,
1779 "%u: xvxvxvxvxvxvx END STEP LAMBDA " SIZE_T_FMT " xvxvxvxvxvx",
1780 exec->uid, n_idx );
1781#endif /* MLISP_STEP_TRACE_LVL */
1782
1783 /* Cleanup the passthrough note for this heartbeat. */
1784 mdata_vector_remove_last( &(exec->lambda_trace) );
1785
1786 return retval;
1787}
1788
1789/* === */
1790
1791static MERROR_RETVAL _mlisp_stack_cleanup(
1792 struct MLISP_PARSER* parser, size_t n_idx, struct MLISP_EXEC_STATE* exec
1793) {
1794 MERROR_RETVAL retval = MERROR_OK;
1795 ssize_t i = 0;
1796 struct MLISP_STACK_NODE o;
1797
1798 /* Pop elements off the stack until we hit the matching begin frame. */
1799 i = mdata_vector_ct( &(exec->stack) ) - 1;
1800 while( 0 <= i ) {
1801
1802 retval = mlisp_stack_pop( exec, &o );
1803 maug_cleanup_if_not_ok();
1804
1805 if( MLISP_TYPE_BEGIN == o.type && n_idx == o.value.begin ) {
1806 break;
1807 }
1808
1809 i--;
1810 }
1811
1812cleanup:
1813
1814 return retval;
1815}
1816
1817/* === */
1818
1823static MERROR_RETVAL _mlisp_eval_token_strpool(
1824 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec,
1825 size_t token_idx, size_t token_sz, struct MLISP_ENV_NODE* e_out
1826) {
1827 MERROR_RETVAL retval = MERROR_OK;
1828 struct MLISP_ENV_NODE* p_e = NULL;
1829 char* strpool_token = NULL;
1830
1831 /* Make sure we're sharing env context with our caller! */
1832 /* assert(
1833 mdata_table_is_locked( &(exec->env) ) ); */
1834 assert( /* Also make sure we're sharing ctx for global env if present! */
1835 NULL == exec->global_env ||
1836 mdata_table_is_locked( exec->global_env ) );
1837
1838 mdata_strpool_lock( &(parser->strpool) );
1839
1840 /* TODO: Use exec_state strpool. */
1841 strpool_token = mdata_strpool_get( &(parser->strpool), token_idx );
1842 assert( NULL != strpool_token );
1843
1844#if MLISP_EXEC_TRACE_LVL > 0
1845 debug_printf( MLISP_EXEC_TRACE_LVL,
1846 "%u: eval token: \"%s\" (strlen: " SIZE_T_FMT "r/" SIZE_T_FMT "d)",
1847 exec->uid, strpool_token, token_sz, maug_strlen( strpool_token ) );
1848#endif /* MLISP_EXEC_TRACE_LVL */
1849 if( 0 == maug_strncmp( strpool_token, "begin", token_sz + 1 ) ) {
1850 /* Fake env node e to signal step_iter() to place/cleanup stack frame. */
1851 e_out->type = MLISP_TYPE_BEGIN;
1852
1853 } else if( NULL != (p_e = mlisp_env_get( exec, strpool_token ) ) ) {
1854 /* A literal found in the environment. */
1855#if MLISP_EXEC_TRACE_LVL > 0
1856 debug_printf( MLISP_EXEC_TRACE_LVL, "%u: found %s in env!",
1857 exec->uid, strpool_token );
1858#endif /* MLISP_EXEC_TRACE_LVL */
1859
1860 /* Copy onto native stack so we can unlock env in case this is a
1861 * callback that needs to execute. */
1862 memcpy( e_out, p_e, sizeof( struct MLISP_ENV_NODE ) );
1863 p_e = NULL;
1864
1865 } else if( maug_is_num( strpool_token, token_sz, 10, 1 ) ) {
1866 /* Fake env node e from a numeric literal. */
1867#if MLISP_EXEC_TRACE_LVL > 0
1868 debug_printf( MLISP_EXEC_TRACE_LVL,
1869 "%u: did not find %s in env, but it is a number...",
1870 exec->uid, strpool_token );
1871#endif /* MLISP_EXEC_TRACE_LVL */
1872 e_out->value.integer = maug_atos32( strpool_token, token_sz );
1873 e_out->type = MLISP_TYPE_INT;
1874
1875 } else if( maug_is_float( strpool_token, token_sz ) ) {
1876#if MLISP_EXEC_TRACE_LVL > 0
1877 debug_printf( MLISP_EXEC_TRACE_LVL,
1878 "%u: did not find %s in env, but it is a float...",
1879 exec->uid, strpool_token );
1880#endif /* MLISP_EXEC_TRACE_LVL */
1881 /* Fake env node e from a floating point numeric literal. */
1882 e_out->value.floating = maug_atof( strpool_token, token_sz );
1883 e_out->type = MLISP_TYPE_FLOAT;
1884
1885 } else {
1886#if MLISP_EXEC_TRACE_LVL > 0
1887 error_printf( "%u: could not make sense of token: %s",
1888 exec->uid, strpool_token );
1889#endif /* MLISP_EXEC_TRACE_LVL */
1890
1891 }
1892
1893cleanup:
1894
1895 if( mdata_strpool_is_locked( &(parser->strpool) ) ) {
1896 mdata_strpool_unlock( &(parser->strpool) );
1897 }
1898
1899#if MLISP_EXEC_TRACE_LVL > 0
1900 debug_printf( MLISP_EXEC_TRACE_LVL, "%u: eval token complete!",
1901 exec->uid );
1902#endif /* MLISP_EXEC_TRACE_LVL */
1903
1904 return retval;
1905}
1906
1907static MERROR_RETVAL _mlisp_step_iter(
1908 struct MLISP_PARSER* parser,
1909 size_t n_idx, struct MLISP_EXEC_STATE* exec
1910) {
1911 MERROR_RETVAL retval = MERROR_OK;
1912 struct MLISP_ENV_NODE e;
1913 struct MLISP_AST_NODE* n = NULL;
1914 size_t* p_visit_ct = NULL;
1915 mlisp_env_cb_t e_cb = NULL;
1916 uint8_t e_flags = 0;
1917 mlisp_lambda_t e_lambda = 0;
1918 int8_t env_iter = 0;
1919
1920 /* With -O2, gcc seems to sometimes(?) push an arbitrary integer to the
1921 * stack, unless we use this variable force it to pass the literal index.
1922 * This *seems* to resolve the issue.
1923 */
1924 volatile mdata_strpool_idx_t node_strpool_idx = 0;
1925
1926#ifdef MLISP_DEBUG_TRACE
1927 exec->trace[exec->trace_depth++] = n_idx;
1928 assert( exec->trace_depth <= MLISP_DEBUG_TRACE );
1929#endif /* MLISP_DEBUG_TRACE */
1930
1931 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1932
1933 assert( mdata_vector_is_locked( &(exec->per_node_visit_ct) ) );
1934 p_visit_ct = mdata_vector_get(
1935 &(exec->per_node_visit_ct), n_idx, size_t );
1936 assert( NULL != p_visit_ct );
1937 (*p_visit_ct)++;
1938#if MLISP_STEP_TRACE_LVL > 0
1939 debug_printf( MLISP_STEP_TRACE_LVL,
1940 "%u: visit count for AST node " SIZE_T_FMT ": " SIZE_T_FMT,
1941 exec->uid, n_idx, *p_visit_ct );
1942#endif /* MLISP_STEP_TRACE_LVL */
1943
1944 /* Push a stack frame marker on the first visit to a BEGIN node. */
1945 if(
1946 MLISP_AST_FLAG_BEGIN == (MLISP_AST_FLAG_BEGIN & n->flags) &&
1947 1 == *p_visit_ct
1948 ) {
1949 /* Push a stack frame on first visit. */
1950 retval = _mlisp_stack_push_mlisp_begin_t( exec, n_idx );
1951 maug_cleanup_if_not_ok();
1952 }
1953
1954 if(
1955 MERROR_OK !=
1956 (retval = _mlisp_step_iter_children( parser, n_idx, exec ))
1957 ) {
1958 goto cleanup;
1959 }
1960
1961 /* Check for special types like lambda, that are lazily evaluated. */
1962 if( MLISP_AST_FLAG_LAMBDA == (MLISP_AST_FLAG_LAMBDA & n->flags) ) {
1963 /* Push the lambda to the stack so that the "define" above it can
1964 * grab it and associate it with the env.
1965 */
1966 /* TODO: Assert node above it is a define! */
1967 mlisp_stack_push( exec, n_idx, mlisp_lambda_t );
1968 goto cleanup;
1969 }
1970
1971 /* Now that the children have been evaluated above, evaluate this node.
1972 * Assume all the previously called children are now on the stack.
1973 */
1974
1975 /* Lock the env so we can grab the token from it and evalauate it below
1976 * in one swoop without an unlock.
1977 */
1978 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
1979#if MLISP_LOCK_TRACE_LVL > 0
1980 debug_printf( MLISP_LOCK_TRACE_LVL,
1981 "%u: locking local env %d...", exec->uid, env_iter );
1982#endif /* MLISP_LOCK_TRACE_LVL */
1983 mdata_table_lock( &(exec->env[env_iter]) );
1984 }
1985
1986 assert(
1987 NULL == exec->global_env || !mdata_table_is_locked( exec->global_env ) );
1988 if( NULL != exec->global_env ) {
1989 mdata_table_lock( exec->global_env );
1990 }
1991
1992 /* Grab the token for this node and figure out what it is. */
1993 retval = _mlisp_eval_token_strpool(
1994 parser, exec, n->token_idx, n->token_sz, &e );
1995 maug_cleanup_if_not_ok();
1996
1997 /* Prepare to step. */
1998
1999#if MLISP_STEP_TRACE_LVL > 0
2000 debug_printf( MLISP_STEP_TRACE_LVL, "%u: acting on evaluated token...",
2001 exec->uid );
2002#endif /* MLISP_STEP_TRACE_LVL */
2003
2004 /* Put the token or its result (if callable) on the stack. */
2005# define _MLISP_TYPE_TABLE_ENVE( idx, ctype, name, const_name, fmt ) \
2006 } else if( MLISP_TYPE_ ## const_name == e.type ) { \
2007 debug_printf( MLISP_EXEC_TRACE_LVL, \
2008 "%u: pushing env: " fmt " to stack...", \
2009 exec->uid, e.value.name ); \
2010 retval = _mlisp_stack_push_ ## ctype( exec, e.value.name ); \
2011 maug_cleanup_if_not_ok();
2012
2014 /* Avoid a deadlock when *re*-assigning terms caused by term being
2015 * evaluated before it is defined.
2016 */
2017#if MLISP_EXEC_TRACE_LVL > 0
2018 debug_printf( MLISP_EXEC_TRACE_LVL,
2019 "%u: special case! pushing literal to stack: " SSIZE_T_FMT,
2020 exec->uid, n->token_idx );
2021#endif /* MLISP_EXEC_TRACE_LVL */
2022 node_strpool_idx = n->token_idx;
2023 retval = _mlisp_stack_push_mdata_strpool_idx_t( exec, node_strpool_idx );
2024 maug_cleanup_if_not_ok();
2025 } else if( MLISP_TYPE_BEGIN == e.type ) {
2026 /* Cleanup the stack that's been pushed by children since this BEGIN's
2027 * initial visit.
2028 */
2029#if MLISP_STEP_TRACE_LVL > 0
2030 debug_printf( MLISP_STEP_TRACE_LVL,
2031 "%u: rewinding stack for begin on node " SSIZE_T_FMT,
2032 exec->uid, n_idx );
2033#endif /* MLISP_STEP_TRACE_LVL */
2034 retval = _mlisp_stack_cleanup( parser, n_idx, exec );
2035 maug_cleanup_if_not_ok();
2036
2037 /* Push a replacement BEGIN that can be caught later and throw an
2038 * MERROR_RESET.
2039 */
2040 retval = _mlisp_stack_push_mlisp_begin_t( exec, n_idx );
2041 maug_cleanup_if_not_ok();
2042
2043 } else if( MLISP_TYPE_CB == e.type ) {
2044 /* This is a special case... rather than pushing the callback, *execute*
2045 * it and let it push its result to the stack. This will create a
2046 * redundant case below, but that can't be helped...
2047 */
2048
2049#if MLISP_EXEC_TRACE_LVL > 0
2050 debug_printf( MLISP_EXEC_TRACE_LVL,
2051 "%u: special case! executing callback: %p", exec->uid, e_cb );
2052#endif /* MLISP_EXEC_TRACE_LVL */
2053
2054 /* Unlock the env so the callback below can use it if needed. */
2055 e_cb = e.value.cb;
2056 e_flags = e.flags;
2057 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2058 mdata_table_unlock( &(exec->env[env_iter]) );
2059 }
2060 if( NULL != exec->global_env ) {
2061 mdata_table_unlock( exec->global_env );
2062 }
2063
2064 retval = e_cb(
2065 parser, exec, n_idx, n->ast_idx_children_sz, NULL, e_flags );
2066
2067 /* Relock it for the benefit of the unlock in cleanup. */
2068 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2069 mdata_table_lock( &(exec->env[env_iter]) );
2070 }
2071 if( NULL != exec->global_env ) {
2072 mdata_table_lock( exec->global_env );
2073 }
2074
2075 } else if( MLISP_TYPE_LAMBDA == e.type ) {
2076
2077#if MLISP_EXEC_TRACE_LVL > 0
2078 debug_printf( MLISP_EXEC_TRACE_LVL,
2079 "%u: special case! executing lambda...", exec->uid );
2080#endif /* MLISP_EXEC_TRACE_LVL */
2081
2082 /* Create a "portal" into the lambda. The execution chain stays pointing
2083 * to this lambda-call node, but _mlisp_step_lambda() returns
2084 * MERROR_PREEMPT up the chain for subsequent heartbeats, until lambda is
2085 * done.
2086 */
2087 e_lambda = e.value.lambda;
2088 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2089 mdata_table_unlock( &(exec->env[env_iter]) );
2090 }
2091 if( NULL != exec->global_env ) {
2092 mdata_table_unlock( exec->global_env );
2093 }
2094
2095 retval = _mlisp_step_lambda( parser, e_lambda, exec );
2096
2097 /* Relock it for the benefit of the unlock in cleanup. */
2098 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2099 mdata_table_lock( &(exec->env[env_iter]) );
2100 }
2101 if( NULL != exec->global_env ) {
2102 mdata_table_lock( exec->global_env );
2103 }
2104
2105 MLISP_TYPE_TABLE( _MLISP_TYPE_TABLE_ENVE )
2106 } else {
2107#if MLISP_EXEC_TRACE_LVL > 0
2108 debug_printf( MLISP_EXEC_TRACE_LVL, "pushing literal into stack" );
2109#endif /* !MLISP_EXEC_TRACE_LVL */
2110 retval = _mlisp_stack_push_mdata_strpool_idx_t( exec, n->token_idx );
2111 maug_cleanup_if_not_ok();
2112 }
2113
2114cleanup:
2115
2116 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2117 mdata_table_unlock( &(exec->env[env_iter]) );
2118 }
2119
2120 if( NULL != exec->global_env ) {
2121 mdata_table_unlock( exec->global_env );
2122 }
2123
2124 return retval;
2125}
2126
2127/* === */
2128
2129static MERROR_RETVAL _mlisp_count_builtins_iter(
2130 const struct MDATA_TABLE_KEY* key, void* data, size_t data_sz,
2131 void* cb_data, size_t cb_data_sz, size_t idx
2132) {
2133 MERROR_RETVAL retval = MERROR_OK;
2134 struct MLISP_ENV_NODE* e = (struct MLISP_ENV_NODE*)data;
2135 ssize_t* p_builtins = (ssize_t*)cb_data;
2136
2137 if( MLISP_ENV_FLAG_BUILTIN == (MLISP_ENV_FLAG_BUILTIN & e->flags) ) {
2138 (*p_builtins)++;
2139 }
2140
2141 return retval;
2142}
2143
2144/* === */
2145
2146ssize_t mlisp_count_builtins( struct MLISP_EXEC_STATE* exec ) {
2147 MERROR_RETVAL retval = MERROR_OK;
2148 ssize_t builtins = 0;
2149 int autolock = 0;
2150
2151 if( 0 == mdata_table_ct( &(exec->env[0]) ) ) {
2152 goto cleanup;
2153 }
2154
2155 if( !mdata_table_is_locked( &(exec->env[0]) ) ) {
2156 mdata_table_lock( &(exec->env[0]) );
2157 autolock = 1;
2158 }
2159
2160 retval = mdata_table_iter(
2161 &(exec->env[0]), _mlisp_count_builtins_iter, &builtins, 0 );
2162
2163cleanup:
2164
2165 if( MERROR_OK != retval ) {
2166 builtins = merror_retval_to_sz( retval );
2167 }
2168
2169 if( autolock ) {
2170 mdata_table_unlock( &(exec->env[0]) );
2171 }
2172
2173 return builtins;
2174}
2175
2176/* === */
2177
2178MERROR_RETVAL mlisp_check_state(
2179 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec
2180) {
2181 MERROR_RETVAL retval = MERROR_OK;
2182
2183 if( !mlisp_check_ast( parser ) ) {
2184 error_printf( "no valid AST present; could not exec!" );
2185 retval = MERROR_EXEC;
2186 goto cleanup;
2187 }
2188
2189 if(
2190 MLISP_EXEC_FLAG_INITIALIZED != (exec->flags & MLISP_EXEC_FLAG_INITIALIZED)
2191 ) {
2192 retval = MERROR_EXEC;
2193 goto cleanup;
2194 }
2195
2196cleanup:
2197
2198 return retval;
2199}
2200
2201/* === */
2202
2204 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec
2205) {
2206 MERROR_RETVAL retval = MERROR_OK;
2207#ifdef MLISP_DEBUG_TRACE
2208 size_t i = 0;
2209 char trace_str[MLISP_DEBUG_TRACE * 5];
2210 maug_ms_t ms_start = 0;
2211 maug_ms_t ms_end = 0;
2212
2213 ms_start = retroflat_get_ms();
2214#endif /* MLISP_DEBUG_TRACE */
2215
2216#if MLISP_STEP_TRACE_LVL > 0
2217 debug_printf( MLISP_STEP_TRACE_LVL, "%u: heartbeat start", exec->uid );
2218#endif /* MLISP_STEP_TRACE_LVL */
2219
2220 /* These can remain locked for the whole step, as they're never added or
2221 * removed.
2222 */
2223 assert( !mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
2224 assert( !mdata_vector_is_locked( &(exec->per_node_visit_ct) ) );
2225 assert( !mdata_vector_is_locked( &(parser->ast) ) );
2228 mdata_vector_lock( &(parser->ast) );
2229
2230 /* Disable transient flags. */
2232 assert( 0 == mdata_vector_ct( &(exec->lambda_trace) ) );
2233
2234#ifdef MLISP_DEBUG_TRACE
2235 exec->trace_depth = 0;
2236#endif /* MLISP_DEBUG_TRACE */
2237
2238 /* Find next unevaluated symbol. */
2239 retval = _mlisp_step_iter( parser, 0, exec );
2240 if( MERROR_PREEMPT == retval ) {
2241 /* There's still more to execute. */
2242 retval = MERROR_OK;
2243 } else if( MERROR_OK == retval ) {
2244 /* The last node executed completely. */
2245#if MLISP_EXEC_TRACE_LVL > 0
2246 debug_printf( MLISP_EXEC_TRACE_LVL,
2247 "%u: execution terminated successfully", exec->uid );
2248#endif /* MLISP_EXEC_TRACE_LVL */
2249 retval = MERROR_EXEC; /* Signal the caller: we're out of instructions! */
2250#if MLISP_EXEC_TRACE_LVL > 0
2251 } else {
2252 debug_printf( MLISP_EXEC_TRACE_LVL,
2253 "%u: execution terminated with retval: %d", exec->uid, retval );
2254#endif /* MLISP_EXEC_TRACE_LVL */
2255 }
2256
2257#ifdef MLISP_DEBUG_TRACE
2258 ms_end = retroflat_get_ms();
2259
2260 maug_mzero( trace_str, MLISP_DEBUG_TRACE * 5 );
2261 for( i = 0 ; exec->trace_depth > i ; i++ ) {
2262 maug_snprintf(
2263 &(trace_str[maug_strlen( trace_str )]),
2264 (MLISP_DEBUG_TRACE * 5) - maug_strlen( trace_str ),
2265 SIZE_T_FMT ", ", exec->trace[i] );
2266 }
2267#if MLISP_STEP_TRACE_LVL > 0
2268 debug_printf( MLISP_STEP_TRACE_LVL,
2269 "%u: " MLISP_TRACE_SIGIL " HBEXEC (%u): %s",
2270 exec->uid, ms_end - ms_start, trace_str );
2271#endif /* MLISP_STEP_TRACE_LVL */
2272#endif /* MLISP_DEBUG_TRACE */
2273
2274cleanup:
2275
2276#if MLISP_STEP_TRACE_LVL > 0
2277 debug_printf( MLISP_STEP_TRACE_LVL,
2278 "%u: heartbeat end: %x", exec->uid, retval );
2279#endif /* MLISP_STEP_TRACE_LVL */
2280
2281 assert( mdata_vector_is_locked( &(parser->ast) ) );
2282 mdata_vector_unlock( &(parser->ast) );
2285
2286 return retval;
2287}
2288
2289/* === */
2290
2292 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec,
2293 const char* lambda
2294) {
2295 struct MLISP_ENV_NODE* e = NULL;
2296 MERROR_RETVAL retval = MERROR_OK;
2297 uint8_t autolock[MLISP_EXEC_ENV_FRAME_CT_MAX];
2298 mlisp_lambda_t lambda_idx = 0;
2299 struct MLISP_AST_NODE* n = NULL;
2300 int8_t env_iter = 0;
2301
2302 if( MERROR_OK != mlisp_check_state( parser, exec ) ) {
2303 error_printf( "mlisp not ready!" );
2304 retval = MERROR_EXEC;
2305 goto cleanup;
2306 }
2307
2308 retval = _mlisp_autolock( parser, exec, 0xff, autolock );
2309 maug_cleanup_if_not_ok();
2310
2311 /* Find the AST node for the lambda. */
2312 e = mlisp_env_get( exec, lambda );
2313 if( NULL == e ) {
2314 error_printf( "lambda \"%s\" not found!", lambda );
2315 retval = MERROR_OVERFLOW;
2316 goto cleanup;
2317 }
2318 lambda_idx = e->value.lambda;
2319
2320 /* Autounlock just env so _mlisp_step_lambda() works. */
2321 /* We use autolock with the env minimally to avoid passing around bad
2322 * pointers.
2323 */
2324 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2325 if( MLISP_AUTOLOCK_EXEC_ENV == (MLISP_AUTOLOCK_EXEC_ENV & autolock[0]) ) {
2326 mdata_table_unlock( &(exec->env[env_iter]) );
2327 autolock[env_iter] &= ~MLISP_AUTOLOCK_EXEC_ENV;
2328 }
2329 }
2330 if(
2331 MLISP_AUTOLOCK_GLOBAL_ENV == (MLISP_AUTOLOCK_GLOBAL_ENV & autolock[0])
2332 ) {
2333 mdata_table_unlock( exec->global_env );
2334 autolock[0] &= ~MLISP_AUTOLOCK_GLOBAL_ENV;
2335 }
2336
2337#if MLISP_STEP_TRACE_LVL > 0
2338 debug_printf( MLISP_STEP_TRACE_LVL, "%u: lambda \"%s\" is AST node idx %ld",
2339 exec->uid, lambda, lambda_idx );
2340#endif /* MLISP_STEP_TRACE_LVL */
2341
2342 n = mdata_vector_get( &(parser->ast), lambda_idx, struct MLISP_AST_NODE );
2343 if( MLISP_AST_FLAG_LAMBDA != (MLISP_AST_FLAG_LAMBDA & n->flags) ) {
2344 error_printf( "invalid node %d: not a lambda!", lambda_idx );
2345 retval = MERROR_EXEC;
2346 goto cleanup;
2347 }
2348
2349 /* Jump execution to the lambda on next iter. */
2350 retval = _mlisp_step_lambda( parser, lambda_idx, exec );
2351
2352cleanup:
2353
2354 _mlisp_autounlock( parser, exec, autolock );
2355
2356 return retval;
2357}
2358
2359/* === */
2360
2361MERROR_RETVAL mlisp_exec_add_env_builtins(
2362 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec
2363) {
2364 MERROR_RETVAL retval = MERROR_OK;
2365
2366 retval = mlisp_env_set(
2367 exec, "gdefine", 7, MLISP_TYPE_CB, _mlisp_env_cb_define,
2368 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_DEFINE_GLOBAL );
2369 maug_cleanup_if_not_ok();
2370
2371 retval = mlisp_env_set(
2372 exec, "and", 3, MLISP_TYPE_CB, _mlisp_env_cb_ano,
2373 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_ANO_AND );
2374 maug_cleanup_if_not_ok();
2375
2376 retval = mlisp_env_set(
2377 exec, "or", 2, MLISP_TYPE_CB, _mlisp_env_cb_ano,
2378 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_ANO_OR );
2379 maug_cleanup_if_not_ok();
2380
2381#ifndef MAUG_NO_RETRO
2382/* TODO: Call this in retroflat in line with dependency guidelines. */
2383 retval = mlisp_env_set(
2384 exec, "random", 6, MLISP_TYPE_CB, _mlisp_env_cb_random,
2385 0, MLISP_ENV_FLAG_BUILTIN );
2386 maug_cleanup_if_not_ok();
2387#endif /* !MAUG_NO_RETRO */
2388
2389 retval = mlisp_env_set(
2390 exec, "if", 2, MLISP_TYPE_CB, _mlisp_env_cb_if,
2391 0, MLISP_ENV_FLAG_BUILTIN );
2392 maug_cleanup_if_not_ok();
2393
2394 retval = mlisp_env_set(
2395 exec, "debug", 5, MLISP_TYPE_CB, _mlisp_env_cb_debug,
2396 0, MLISP_ENV_FLAG_BUILTIN );
2397 maug_cleanup_if_not_ok();
2398
2399 retval = mlisp_env_set(
2400 exec, "define", 6, MLISP_TYPE_CB, _mlisp_env_cb_define,
2401 0, MLISP_ENV_FLAG_BUILTIN );
2402 maug_cleanup_if_not_ok();
2403
2404 retval = mlisp_env_set(
2405 exec, "*", 1, MLISP_TYPE_CB, _mlisp_env_cb_arithmetic,
2406 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_ARI_MUL );
2407 maug_cleanup_if_not_ok();
2408
2409 retval = mlisp_env_set(
2410 exec, "+", 1, MLISP_TYPE_CB, _mlisp_env_cb_arithmetic,
2411 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_ARI_ADD );
2412 maug_cleanup_if_not_ok();
2413
2414 retval = mlisp_env_set(
2415 exec, "/", 1, MLISP_TYPE_CB, _mlisp_env_cb_arithmetic,
2416 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_ARI_DIV );
2417 maug_cleanup_if_not_ok();
2418
2419 retval = mlisp_env_set(
2420 exec, "%", 1, MLISP_TYPE_CB, _mlisp_env_cb_arithmetic,
2421 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_ARI_MOD );
2422 maug_cleanup_if_not_ok();
2423
2424 retval = mlisp_env_set(
2425 exec, "<", 1, MLISP_TYPE_CB, _mlisp_env_cb_cmp,
2426 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_CMP_LT );
2427 maug_cleanup_if_not_ok();
2428
2429 retval = mlisp_env_set(
2430 exec, ">", 1, MLISP_TYPE_CB, _mlisp_env_cb_cmp,
2431 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_CMP_GT );
2432 maug_cleanup_if_not_ok();
2433
2434 retval = mlisp_env_set(
2435 exec, "=", 1, MLISP_TYPE_CB, _mlisp_env_cb_cmp,
2436 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_CMP_EQ );
2437 maug_cleanup_if_not_ok();
2438
2439cleanup:
2440
2441 return retval;
2442}
2443
2444/* === */
2445
2446MERROR_RETVAL mlisp_exec_init(
2447 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, uint8_t flags
2448) {
2449 MERROR_RETVAL retval = MERROR_OK;
2450 ssize_t append_retval = 0;
2451 size_t zero = 0;
2452 int16_t null_val = 0;
2453
2454 assert( 0 == exec->flags );
2455
2456 maug_mzero( exec, sizeof( struct MLISP_EXEC_STATE ) );
2457
2458 exec->flags = flags;
2459 exec->uid = g_mlispe_last_uid++;
2460
2461 /* Setup lambda visit stack so it can be locked on first step. */
2462 append_retval = mdata_vector_append(
2463 &(exec->lambda_trace), &zero, sizeof( size_t ) );
2464 if( 0 > append_retval ) {
2465 retval = mdata_retval( append_retval );
2466 }
2467 maug_cleanup_if_not_ok();
2468 mdata_vector_remove_last( &(exec->lambda_trace) );
2469
2470 /* Define a constant so that the table is never empty, which makes things
2471 * run more smoothly.
2472 */
2473 retval = mlisp_env_set(
2474 exec, "null", 4, MLISP_TYPE_INT, &null_val, 0, 0 );
2475
2476 /* Create the node PCs. */
2477 append_retval = mdata_vector_append(
2478 &(exec->per_node_child_idx), &zero, sizeof( size_t ) );
2479 if( 0 > append_retval ) {
2480 retval = mdata_retval( append_retval );
2481 }
2482 maug_cleanup_if_not_ok();
2483
2484 /* Make sure there's an exec child node for every AST node. */
2485 while(
2486 mdata_vector_ct( &(exec->per_node_child_idx) ) <=
2487 mdata_vector_ct( &(parser->ast) )
2488 ) {
2489 append_retval = mdata_vector_append( &(exec->per_node_child_idx), &zero,
2490 sizeof( size_t ) );
2491 if( 0 > append_retval ) {
2492 retval = mdata_retval( append_retval );
2493 }
2494 maug_cleanup_if_not_ok();
2495 }
2496
2497 /* Create the node visit counters. */
2498 append_retval = mdata_vector_append(
2499 &(exec->per_node_visit_ct), &zero, sizeof( size_t ) );
2500 if( 0 > append_retval ) {
2501 retval = mdata_retval( append_retval );
2502 }
2503 maug_cleanup_if_not_ok();
2504
2505 /* Make sure there's an exec visit count for every AST node. */
2506 while(
2507 mdata_vector_ct( &(exec->per_node_visit_ct) ) <=
2508 mdata_vector_ct( &(parser->ast) )
2509 ) {
2510 append_retval = mdata_vector_append( &(exec->per_node_visit_ct), &zero,
2511 sizeof( size_t ) );
2512 if( 0 > append_retval ) {
2513 retval = mdata_retval( append_retval );
2514 }
2515 maug_cleanup_if_not_ok();
2516 }
2517
2518 exec->flags |= MLISP_EXEC_FLAG_INITIALIZED;
2519
2520 /* Setup initial env. */
2521
2522 retval = mlisp_exec_add_env_builtins( parser, exec );
2523
2524cleanup:
2525
2526 if( MERROR_OK != retval ) {
2527 error_printf( "mlisp exec initialization failed: %d", retval );
2528 }
2529
2530 return retval;
2531}
2532
2533/* === */
2534
2536 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec,
2537 struct MDATA_TABLE* global_env
2538) {
2539 MERROR_RETVAL retval = MERROR_OK;
2540 int16_t null_val = 0;
2541
2542 exec->global_env = global_env;
2543
2544 if( 0 == mdata_table_ct( global_env ) ) {
2545 /* Things get very wonky if the env is completely empty due to how empty
2546 * vectors respond to locking. This is a simple way of working around
2547 * that rather than adding a lot of special cases!
2548 */
2549 retval = mlisp_env_set(
2550 exec, "null", 4, MLISP_TYPE_INT, &null_val, 1, 0 );
2551 }
2552
2553 return retval;
2554}
2555
2556/* === */
2557
2558void mlisp_exec_free( struct MLISP_EXEC_STATE* exec ) {
2559 int8_t env_iter = 0;
2560
2561#if MLISP_EXEC_TRACE_LVL > 0
2562 debug_printf( MLISP_EXEC_TRACE_LVL,
2563 "%u: destroying exec (stack: " SIZE_T_FMT ", env: " SIZE_T_FMT ")...",
2564 exec->uid,
2565 mdata_vector_ct( &(exec->stack) ),
2566 mdata_table_ct( &(exec->env[exec->env_select]) ) );
2567#endif /* MLISP_EXEC_TRACE_LVL */
2568 mdata_vector_free( &(exec->per_node_child_idx) );
2569 mdata_vector_free( &(exec->per_node_visit_ct) );
2570 mdata_vector_free( &(exec->stack) );
2571 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2572 mdata_table_free( &(exec->env[env_iter]) );
2573 }
2574 mdata_vector_free( &(exec->lambda_trace) );
2575 exec->flags = 0;
2576#if MLISP_EXEC_TRACE_LVL > 0
2577 debug_printf( MLISP_EXEC_TRACE_LVL, "exec destroyed!" );
2578#endif /* MLISP_EXEC_TRACE_LVL */
2579}
2580
2581/* === */
2582
2583MERROR_RETVAL mlisp_deserialize_prepare_EXEC_STATE(
2584 struct MLISP_EXEC_STATE* exec, size_t i
2585) {
2586 MERROR_RETVAL retval = MERROR_OK;
2587 /* TODO: Re-add built-in function definitions. */
2588 /* TODO: Provide mechanism for program using maug to re-add function
2589 * definitions!
2590 */
2591 return retval;
2592}
2593
2594#else
2595
2596# define MLISP_PSTATE_TABLE_CONST( name, idx ) \
2597 extern MAUG_CONST uint8_t SEG_MCONST name;
2598
2599MLISP_PARSER_PSTATE_TABLE( MLISP_PSTATE_TABLE_CONST )
2600
2601#ifdef MPARSER_TRACE_NAMES
2602extern MAUG_CONST char* SEG_MCONST gc_mlisp_pstate_names[];
2603#endif /* MPARSER_TRACE_NAMES */
2604
2605#endif /* MLISPE_C */
2606
2607#endif /* !MLISPE_H */
2608
uint16_t MERROR_RETVAL
Return type indicating function returns a value from this list.
Definition: merror.h:28
#define MERROR_PREEMPT
Indicates MLISP_AST_NODE can be executed again on next step iter pass.
Definition: merror.h:67
#define MERROR_RESET
Indicates MLISP_EXEC_STATE has reached a condition where it has run out of instructions.
Definition: merror.h:73
#define mdata_strpool_get(sp, idx)
Get a string by the index of its first character in the strpool.
Definition: mdata.h:334
MAUG_MHANDLE mdata_strpool_extract(struct MDATA_STRPOOL *sp, mdata_strpool_idx_t idx)
Return a dynamically-allocated memory handle containing the contents of the string at the given index...
ssize_t mdata_vector_append(struct MDATA_VECTOR *v, const void *item, size_t item_sz)
Append an item to the specified vector.
MERROR_RETVAL mdata_vector_remove(struct MDATA_VECTOR *v, size_t idx)
Remove item at the given index, shifting subsequent items up by 1.
#define mlisp_check_ast(parser)
Macro to check if a parser contains a valid AST ready to be executed.
Definition: mlispp.h:80
MERROR_RETVAL mlisp_stack_dump(struct MLISP_PARSER *parser, struct MLISP_EXEC_STATE *exec)
Dump the stack from the given parser/exec combination.
#define mlisp_stack_pop(exec, o)
Wrapper for mlisp_stack_pop() with no flags.
Definition: mlispe.h:123
#define MLISP_STACK_FLAG_PEEK
Flag for mlisp_stack_pop_ex() indicating the value should not be removed from the stack.
Definition: mlispe.h:118
#define mlisp_stack_push(exec, i, ctype)
Push a value onto MLISP_EXEC_STATE::stack.
Definition: mlispe.h:133
MERROR_RETVAL mlisp_stack_pop_ex(struct MLISP_EXEC_STATE *exec, struct MLISP_STACK_NODE *o, uint8_t flags)
Pop a value off of (removing from) MLISP_EXEC_STATE::stack and copy it to a provided output.
#define MLISP_TYPE_TABLE(f)
Table of other types.
Definition: mlisps.h:74
#define MLISP_NUM_TYPE_TABLE(f)
Table of numeric types.
Definition: mlisps.h:64
MERROR_RETVAL mlisp_exec_set_global_env(struct MLISP_PARSER *parser, struct MLISP_EXEC_STATE *exec, struct MDATA_TABLE *global_env)
Set the given exec state to use the given vector as a global variable environment....
#define MLISP_ENV_FLAG_CMP_GT
Flag for _mlisp_env_cb_cmp() specifying TRUE if A > B.
Definition: mlispe.h:74
MERROR_RETVAL(* mlisp_env_cb_t)(struct MLISP_PARSER *parser, struct MLISP_EXEC_STATE *exec, size_t n_idx, size_t args_c, uint8_t *cb_data, uint8_t flags)
A callback to attach to an mlisp command with mlisp_env_set() with MLISP_TYPE_CB.
Definition: mlisps.h:92
#define MLISP_ENV_FLAG_ARI_MUL
Flag for _mlisp_env_cb_arithmetic() specifying to multiply A * B.
Definition: mlispe.h:86
MERROR_RETVAL mlisp_step(struct MLISP_PARSER *parser, struct MLISP_EXEC_STATE *exec)
Iterate the current exec_state() starting from the next MLISP_AST_NODE to be executed according to th...
#define MLISP_ENV_FLAG_ARI_ADD
Flag for _mlisp_env_cb_arithmetic() specifying to add A + B.
Definition: mlispe.h:83
#define MLISP_ENV_FLAG_CMP_EQ
Flag for _mlisp_env_cb_cmp() specifying TRUE if A == B.
Definition: mlispe.h:80
MERROR_RETVAL mlisp_env_dump(struct MLISP_PARSER *parser, struct MLISP_EXEC_STATE *exec, uint8_t global)
Dump the environment from the given parser/exec combination.
MERROR_RETVAL mlisp_step_lambda(struct MLISP_PARSER *parser, struct MLISP_EXEC_STATE *exec, const char *lambda)
Iterate the current exec_state() starting from the lambda named.
#define MLISP_ENV_FLAG_CMP_LT
Flag for _mlisp_env_cb_cmp() specifying TRUE if A < B.
Definition: mlispe.h:77
#define MLISP_ENV_FLAG_DEFINE_GLOBAL
Flag for _mlisp_env_cb_define() specifying global env.
Definition: mlispe.h:97
MLISP Interpreter/Parser Structs.
Definition: mdata.h:136
Definition: mdata.h:142
#define mdata_vector_lock(v)
Lock the vector. This should be done when items from the vector are actively being referenced,...
Definition: mdata.h:372
#define mdata_vector_unlock(v)
Unlock the vector so items may be added and removed.
Definition: mdata.h:405
#define mdata_vector_ct(v)
Number of items of MDATA_VECTOR::item_sz bytes actively stored in this vector.
Definition: mdata.h:448
Definition: mlisps.h:118
size_t ast_idx_children_sz
Number of children in MLISP_AST_NODE::ast_idx_children.
Definition: mlisps.h:126
Definition: mlisps.h:107
Current execution state to associate with a MLISP_PARSER.
Definition: mlisps.h:136
struct MDATA_VECTOR lambda_trace
Path through any lambdas the execution has entered during this heartbeat cycle. Used to detect tail c...
Definition: mlisps.h:184
#define MLISP_EXEC_FLAG_TRANSIENT_MASK
Mask for MLISP_EXEC_STATE::flags to block off flags that persist between steps.
Definition: mlisps.h:34
struct MDATA_VECTOR per_node_child_idx
The hild index that will be visited on next visit of each node.
Definition: mlisps.h:151
struct MDATA_VECTOR per_node_visit_ct
The number of times each node has been visited ever.
Definition: mlisps.h:143
#define MLISP_EXEC_FLAG_DEF_TERM
Flag for MLISP_EXEC_STATE::flags indicating next token is a term to be defined.
Definition: mlisps.h:41
struct MDATA_VECTOR stack
A stack of data values resulting from evaluating statements.
Definition: mlisps.h:154
uint8_t flags
Flags which dictate the behavior of this object.
Definition: mlisps.h:140
struct MDATA_TABLE env[MLISP_EXEC_ENV_FRAME_CT_MAX]
Environment in which statements are defined if ::MLISP_.
Definition: mlisps.h:171
int8_t env_select
The current topmost frame of MLISP_EXEC_STATE::env. Please see that for more information.
Definition: mlisps.h:176
Definition: mlisps.h:199
Definition: mlisps.h:113