maug
Quick and dirty C mini-augmentation library.
Loading...
Searching...
No Matches
mlispe.h
Go to the documentation of this file.
1
2#ifndef MLISPE_H
3#define MLISPE_H
4
5#include <mlisps.h>
6
13
42
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
113
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 */
298 mdata_vector_lock( &(exec->per_node_child_idx) );
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 */
309 mdata_vector_lock( &(exec->per_node_visit_ct) );
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]) ) {
357 mdata_vector_unlock( &(exec->per_node_child_idx) );
358 }
359 if( MLISP_AUTOLOCK_VISIT_CT == (MLISP_AUTOLOCK_VISIT_CT & autolock[0]) ) {
360 mdata_vector_unlock( &(exec->per_node_visit_ct) );
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 case idx: \
1045 debug_printf( 2, fmt, val.value.name ); \
1046 break;
1047
1048 switch( val.type ) {
1049 case MLISP_TYPE_STR:
1050 debug_printf( 2, "%s", mdata_strpool_extract(
1051 &(parser->strpool), val.value.strpool_idx ) );
1052 break;
1053 MLISP_NUM_TYPE_TABLE( _MLISP_TYPE_TABLE_DBG )
1054 }
1055
1056cleanup:
1057
1058 return retval;
1059}
1060
1061/* === */
1062
1063static MERROR_RETVAL _mlisp_env_cb_define(
1064 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, size_t n_idx,
1065 size_t args_c, void* cb_data, uint8_t flags
1066) {
1067 MERROR_RETVAL retval = MERROR_OK;
1068 struct MLISP_STACK_NODE key;
1069 struct MLISP_STACK_NODE val;
1070 MAUG_MHANDLE key_tmp_h = (MAUG_MHANDLE)NULL;
1071 char* key_tmp = NULL;
1072 uint8_t global = 0;
1073
1074#if MLISP_EXEC_TRACE_LVL > 0
1075 debug_printf( MLISP_EXEC_TRACE_LVL, "%u: entering define callback...",
1076 exec->uid );
1077#endif /* MLISP_EXEC_TRACE_LVL */
1078
1079 retval = mlisp_stack_pop( exec, &val );
1080 maug_cleanup_if_not_ok();
1081
1082 retval = mlisp_stack_pop( exec, &key );
1083 maug_cleanup_if_not_ok();
1084
1085 if( MLISP_TYPE_STR != key.type ) {
1086 /* TODO: Do we want to allow defining other types? */
1087 /* TODO: We can use _mlisp_eval_token_strpool, maybe? */
1088 error_printf( "define: invalid key type: %d", key.type );
1089 retval = MERROR_EXEC;
1090 goto cleanup;
1091 }
1092
1093#if MLISP_EXEC_TRACE_LVL > 0
1094 debug_printf( MLISP_EXEC_TRACE_LVL,
1095 "%u: extracting define term for idx: " SIZE_T_FMT,
1096 exec->uid, key.value.strpool_idx );
1097#endif /* MLISP_EXEC_TRACE_LVL */
1098
1099 key_tmp_h = mdata_strpool_extract(
1100 &(parser->strpool), key.value.strpool_idx );
1101 /* TODO: Handle this gracefully. */
1102 assert( (MAUG_MHANDLE)NULL != key_tmp_h );
1103
1104 maug_mlock( key_tmp_h, key_tmp );
1105 maug_cleanup_if_null_lock( char*, key_tmp );
1106
1107#if MLISP_EXEC_TRACE_LVL > 0
1108 debug_printf( MLISP_EXEC_TRACE_LVL,
1109 "%u: define \"%s\" (strpool(" SIZE_T_FMT "))...",
1110 exec->uid, key_tmp, key.value.strpool_idx );
1111#endif /* MLISP_EXEC_TRACE_LVL */
1112
1113 /* Figure out the env to use. */
1114 if(
1116 ) {
1117#if MLISP_EXEC_TRACE_LVL > 0
1118 debug_printf( MLISP_EXEC_TRACE_LVL,
1119 "%u: using global env...", exec->uid );
1120#endif /* MLISP_EXEC_TRACE_LVL */
1121 global = 1;
1122 }
1123
1124 /* Perform the insertion. */
1125 retval = mlisp_env_set(
1126 exec, key_tmp, maug_strlen( key_tmp ), val.type, &(val.value),
1127 global, 0 );
1128 maug_cleanup_if_not_ok();
1129
1130#if MLISP_EXEC_TRACE_LVL > 0
1131 debug_printf( MLISP_EXEC_TRACE_LVL,
1132 "%u: setup env node: %s",
1133 exec->uid, key_tmp );
1134#endif /* MLISP_EXEC_TRACE_LVL */
1135
1136cleanup:
1137
1138 if( NULL != key_tmp ) {
1139 maug_munlock( key_tmp_h, key_tmp );
1140 }
1141
1142 if( (MAUG_MHANDLE)NULL != key_tmp_h ) {
1143 maug_mfree( key_tmp_h );
1144 }
1145
1146 return retval;
1147}
1148
1149/* === */
1150
1151static MERROR_RETVAL _mlisp_env_cb_if(
1152 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, size_t n_idx,
1153 size_t args_c, void* cb_data, uint8_t flags
1154) {
1155 MERROR_RETVAL retval = MERROR_OK;
1156 size_t* p_if_child_idx = NULL;
1157 struct MLISP_STACK_NODE s;
1158 struct MLISP_AST_NODE* n = NULL;
1159
1160#if MLISP_STEP_TRACE_LVL > 0
1161 debug_printf( MLISP_STEP_TRACE_LVL,
1162 "%u: qrqrqrqrqr STEP IF qrqrqrqrqr", exec->uid );
1163#endif /* MLISP_STEP_TRACE_LVL */
1164
1165 /* Grab the current exec index for the child vector for this node. */
1166 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1167 p_if_child_idx = mdata_vector_get(
1168 &(exec->per_node_child_idx), n_idx, size_t );
1169 assert( NULL != p_if_child_idx );
1170#if MLISP_STEP_TRACE_LVL > 0
1171 debug_printf( MLISP_STEP_TRACE_LVL,
1172 "%u: node " SIZE_T_FMT " child idx: " SIZE_T_FMT,
1173 exec->uid, n_idx, *p_if_child_idx );
1174#endif /* MLISP_STEP_TRACE_LVL */
1175
1176 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1177
1178 if( 0 == *p_if_child_idx ) {
1179 /* Evaluating if condition. */
1180#if MLISP_STEP_TRACE_LVL > 0
1181 debug_printf( MLISP_STEP_TRACE_LVL,
1182 "%u: stepping into condition...", exec->uid );
1183#endif /* MLISP_STEP_TRACE_LVL */
1184 retval = _mlisp_step_iter(
1185 parser, n->ast_idx_children[*p_if_child_idx], exec );
1186#if MLISP_STEP_TRACE_LVL > 0
1187 debug_printf( MLISP_STEP_TRACE_LVL,
1188 "%u: ...stepped out of condition", exec->uid );
1189#endif /* MLISP_STEP_TRACE_LVL */
1190
1191 /* Vary the child we jump to based on the boolean val on the stack. */
1192 if( MERROR_OK == retval ) {
1193 /* Condition evaluation complete. */
1194
1195 /* Pop the result and check it. */
1196 retval = mlisp_stack_pop( exec, &s );
1197 maug_cleanup_if_not_ok();
1198 if( MLISP_TYPE_BOOLEAN != s.type ) {
1199 error_printf( "(if) can only evaluate boolean type!" );
1200 retval = MERROR_EXEC;
1201 goto cleanup;
1202 }
1203
1204 /* Set the child pointer to 1 if TRUE and 2 if FALSE. */
1205 retval = _mlisp_preempt(
1206 retval, "if", parser, n_idx, exec,
1207 /* Flip boolean and increment. */
1208 (1 - s.value.boolean) + 1 );
1209 }
1210
1211 } else if( args_c > *p_if_child_idx ) { /* 3 if else present, else 2. */
1212 /* Pursuing TRUE or FALSE clause. */
1213
1214#if MLISP_STEP_TRACE_LVL > 0
1215 debug_printf( MLISP_STEP_TRACE_LVL,
1216 "%u: descending into IF path: " SIZE_T_FMT,
1217 exec->uid, *p_if_child_idx );
1218#endif /* MLISP_STEP_TRACE_LVL */
1219
1220 /* Prepare for stepping. */
1221
1222 /* Step and check. */
1223 retval = _mlisp_step_iter(
1224 parser, n->ast_idx_children[*p_if_child_idx], exec );
1225 retval = _mlisp_preempt(
1226 retval, "if", parser, n_idx, exec, 3 );
1227 }
1228
1229cleanup:
1230
1231#if MLISP_STEP_TRACE_LVL > 0
1232 debug_printf( MLISP_STEP_TRACE_LVL,
1233 "%u: qrqrqrqrqr END STEP IF qrqrqrqrqr", exec->uid );
1234#endif /* MLISP_STEP_TRACE_LVL */
1235
1236 return retval;
1237}
1238
1239/* === */
1240
1241#ifndef MAUG_NO_RETRO
1242/* TODO: Define this callback in retroflat in line with dependency guidelines.
1243 */
1244
1245static MERROR_RETVAL _mlisp_env_cb_random(
1246 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, size_t n_idx,
1247 size_t args_c, void* cb_data, uint8_t flags
1248) {
1249 MERROR_RETVAL retval = MERROR_OK;
1250 struct MLISP_STACK_NODE mod;
1251 int16_t random_int = 0;
1252
1253 retval = mlisp_stack_pop( exec, &mod );
1254 maug_cleanup_if_not_ok();
1255
1256 if( MLISP_TYPE_INT != mod.type ) {
1257 /* TODO: Setup float. */
1258 error_printf( "random: invalid modulus type: %d", mod.type );
1259 retval = MERROR_EXEC;
1260 goto cleanup;
1261 }
1262
1263 random_int = retroflat_get_rand() % mod.value.integer;
1264
1265#if MLISP_EXEC_TRACE_LVL > 0
1266 debug_printf( MLISP_EXEC_TRACE_LVL,
1267 "%u: random: %d", exec->uid, random_int );
1268#endif /* MLISP_EXEC_TRACE_LVL */
1269
1270 mlisp_stack_push( exec, random_int, int16_t );
1271
1272cleanup:
1273
1274 return retval;
1275}
1276
1277#endif /* !MAUG_NO_RETRO */
1278
1279/* === */
1280
1281static MERROR_RETVAL _mlisp_env_cb_ano(
1282 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, size_t n_idx,
1283 size_t args_c, void* cb_data, uint8_t flags
1284) {
1285 MERROR_RETVAL retval = MERROR_OK;
1286 struct MLISP_STACK_NODE val;
1287 mlisp_bool_t val_out =
1288 /* Default to false for OR or true for AND. */
1289 MLISP_ENV_FLAG_ANO_OR == (MLISP_ENV_FLAG_ANO_OR & flags) ?
1290 0 : 1;
1291 size_t i = 0;
1292
1293 /* TODO: Switch this to a step_or() function so that we can opt not to
1294 * evaluate conditions unless prior stepped children are false.
1295 */
1296
1297 for( i = 0 ; args_c > i ; i++ ) {
1298 retval = mlisp_stack_pop( exec, &val );
1299 maug_cleanup_if_not_ok();
1300
1301 if( MLISP_TYPE_BOOLEAN != val.type ) {
1302 error_printf( "or: invalid boolean type: %d", val.type );
1303 }
1304
1305 if(
1306 MLISP_ENV_FLAG_ANO_OR == (MLISP_ENV_FLAG_ANO_OR & flags) &&
1307 val.value.boolean
1308 ) {
1309#if MLISP_CMP_TRACE_LVL > 0
1310 debug_printf( MLISP_CMP_TRACE_LVL, "%u: found TRUE in OR compare!",
1311 exec->uid );
1312#endif /* MLISP_CMP_TRACE_LVL */
1313 val_out = 1;
1314 break;
1315 } else if(
1316 MLISP_ENV_FLAG_ANO_AND == (MLISP_ENV_FLAG_ANO_AND & flags) &&
1317 !val.value.boolean
1318 ) {
1319#if MLISP_CMP_TRACE_LVL > 0
1320 debug_printf( MLISP_CMP_TRACE_LVL, "%u: found FALSE in AND compare!",
1321 exec->uid );
1322#endif /* MLISP_CMP_TRACE_LVL */
1323 val_out = 0;
1324 break;
1325 }
1326 }
1327
1328#if MLISP_CMP_TRACE_LVL > 0
1329 debug_printf( MLISP_CMP_TRACE_LVL, "compare result: %d", val_out );
1330#endif /* MLISP_CMP_TRACE_LVL */
1331 retval = _mlisp_stack_push_mlisp_bool_t( exec, val_out );
1332
1333cleanup:
1334
1335 return retval;
1336}
1337
1338/* === */
1339
1340/* Execution Functions */
1341
1342/* === */
1343
1344static MERROR_RETVAL _mlisp_preempt(
1345 MERROR_RETVAL retval, const char* caller, struct MLISP_PARSER* parser,
1346 size_t n_idx, struct MLISP_EXEC_STATE* exec, size_t new_idx
1347) {
1348 struct MLISP_AST_NODE* n = NULL;
1349 size_t* p_child_idx = NULL;
1350
1351 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1352 p_child_idx = mdata_vector_get(
1353 &(exec->per_node_child_idx), n_idx, size_t );
1354 assert( NULL != p_child_idx );
1355
1356 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1357
1358 if( 0 < n->token_idx ) {
1359 mdata_strpool_lock( &(parser->strpool) );
1360#if MLISP_STEP_TRACE_LVL > 0
1361 debug_printf( MLISP_STEP_TRACE_LVL,
1362 "%u: eval step " SSIZE_T_FMT " under (%s) %s...",
1363 exec->uid, *p_child_idx, caller,
1364 mdata_strpool_get( &(parser->strpool), n->token_idx ) );
1365#endif /* MLISP_STEP_TRACE_LVL */
1366 mdata_strpool_unlock( &(parser->strpool) );
1367#if MLISP_STEP_TRACE_LVL > 0
1368 } else {
1369 debug_printf( MLISP_STEP_TRACE_LVL,
1370 "%u: eval step " SSIZE_T_FMT " under (%s) (empty token)...",
1371 exec->uid, *p_child_idx, caller );
1372#endif /* MLISP_STEP_TRACE_LVL */
1373 }
1374
1375 if( MERROR_OK != retval ) {
1376 /* Something bad happened, so don't increment! */
1377#if MLISP_STEP_TRACE_LVL > 0
1378 debug_printf( MLISP_STEP_TRACE_LVL,
1379 "%u: not incrementing node " SIZE_T_FMT " child idx from "
1380 SIZE_T_FMT " (retval: 0x%x)!",
1381 exec->uid, n_idx, *p_child_idx, retval );
1382#endif /* MLISP_STEP_TRACE_LVL */
1383 goto cleanup;
1384 }
1385
1386 /* Could not exec *this* node yet, so don't increment its parent. */
1387 retval = MERROR_PREEMPT;
1388
1389 /* Increment this node, since the child actually executed. */
1390 (*p_child_idx) = new_idx;
1391#if MLISP_STEP_TRACE_LVL > 0
1392 debug_printf( MLISP_STEP_TRACE_LVL,
1393 "%u: incremented node " SIZE_T_FMT " child idx to: " SIZE_T_FMT,
1394 exec->uid, n_idx, *p_child_idx );
1395#endif /* MLISP_STEP_TRACE_LVL */
1396
1397cleanup:
1398
1399 assert( !mdata_strpool_is_locked( &(parser->strpool) ) );
1400
1401 return retval;
1402}
1403
1404/* === */
1405
1406static MERROR_RETVAL _mlisp_step_iter_children(
1407 struct MLISP_PARSER* parser, size_t n_idx, struct MLISP_EXEC_STATE* exec
1408) {
1409 MERROR_RETVAL retval = MERROR_OK;
1410 size_t* p_child_idx = NULL;
1411 struct MLISP_AST_NODE* n = NULL;
1412
1413 /* Grab the current exec index for the child vector for this node. */
1414 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1415 p_child_idx = mdata_vector_get(
1416 &(exec->per_node_child_idx), n_idx, size_t );
1417 assert( NULL != p_child_idx );
1418#if MLISP_STEP_TRACE_LVL > 0
1419 debug_printf( MLISP_STEP_TRACE_LVL,
1420 "%u: node " SIZE_T_FMT " child idx: " SIZE_T_FMT,
1421 exec->uid, n_idx, *p_child_idx );
1422#endif /* MLISP_STEP_TRACE_LVL */
1423
1424 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1425
1426 if(
1427 (
1428 MLISP_AST_FLAG_LAMBDA == (MLISP_AST_FLAG_LAMBDA & n->flags) &&
1429 0 == *p_child_idx
1430 ) ||
1431 MLISP_AST_FLAG_IF == (MLISP_AST_FLAG_IF & n->flags)
1432 ) {
1433 /* A lambda definition was found, and its exec counter is still pointing
1434 * to the arg list. This means the lambda was *not* called on the last
1435 * heartbeat, and we're probably just enountering its definition.
1436 *
1437 * Lambdas are lazily evaluated, so don't pursue it further until it's
1438 * called (stee _mlisp_step_lambda() for more info on this.
1439 */
1440#if MLISP_STEP_TRACE_LVL > 0
1441 debug_printf( MLISP_STEP_TRACE_LVL,
1442 "%u: skipping lambda children...", exec->uid );
1443#endif /* MLISP_STEP_TRACE_LVL */
1444 goto cleanup;
1445 }
1446
1447 if( mlisp_ast_has_ready_children( *p_child_idx, n ) ) {
1448 /* Call the next uncalled child. */
1449
1450 if(
1451 MLISP_AST_FLAG_DEFINE == (MLISP_AST_FLAG_DEFINE & n->flags) &&
1452 0 == *p_child_idx
1453 ) {
1454 /* The next child is a term to be defined. */
1455#if MLISP_EXEC_TRACE_LVL > 0
1456 debug_printf( MLISP_EXEC_TRACE_LVL,
1457 "%u: setting MLISP_EXEC_FLAG_DEF_TERM!", exec->uid );
1458#endif /* MLISP_EXEC_TRACE_LVL */
1459 exec->flags |= MLISP_EXEC_FLAG_DEF_TERM;
1460 } else {
1461 exec->flags &= ~MLISP_EXEC_FLAG_DEF_TERM;
1462 }
1463
1464 /* Step and check. */
1465 retval = _mlisp_step_iter(
1466 parser, n->ast_idx_children[*p_child_idx], exec );
1467 retval = _mlisp_preempt(
1468 retval, "node", parser, n_idx, exec, (*p_child_idx) + 1 );
1469 goto cleanup;
1470 }
1471
1472cleanup:
1473
1474 return retval;
1475}
1476
1477/* === */
1478
1479static MERROR_RETVAL _mlisp_step_lambda_args(
1480 struct MLISP_PARSER* parser, size_t n_idx, struct MLISP_EXEC_STATE* exec
1481) {
1482 MERROR_RETVAL retval = MERROR_OK;
1483 ssize_t arg_idx = 0;
1484 struct MLISP_STACK_NODE stack_n_arg;
1485 struct MLISP_AST_NODE* ast_n_arg = NULL;
1486 MAUG_MHANDLE key_tmp_h = (MAUG_MHANDLE)NULL;
1487 char* key_tmp = NULL;
1488 struct MLISP_AST_NODE* n = NULL;
1489 int16_t null_val = 0;
1490
1491 /* Pop stack into args into the env. These are all the results of previous
1492 * evaluations, before the lambda call, so we can just grab them all in
1493 * one go!
1494 */
1495
1496 /* Create a new env and bump up env_select. */
1497 if( MLISP_EXEC_ENV_FRAME_CT_MAX > exec->env_select + 1 ) {
1498 exec->env_select++;
1499#if MLISP_EXEC_TRACE_LVL > 0
1500 debug_printf( MLISP_EXEC_TRACE_LVL, "selecting env frame: %d",
1501 exec->env_select );
1502#endif /* MLISP_EXEC_TRACE_LVL */
1503 assert( 0 == mdata_table_ct( &(exec->env[exec->env_select]) ) );
1504
1505 /* Toss a constant into the new env so it's not as wonky. */
1506 retval = mlisp_env_set(
1507 exec, "null", 4, MLISP_TYPE_INT, &null_val, 0, 0 );
1508 } else {
1509 error_printf( "env frame overflow!" );
1510 retval = MERROR_OVERFLOW;
1511 goto cleanup;
1512 }
1513
1514 /* Get the current args node. */
1515 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1516 arg_idx = n->ast_idx_children_sz - 1;
1517
1518 while( 0 <= arg_idx ) {
1519
1520 retval = mlisp_stack_pop( exec, &stack_n_arg );
1521 maug_cleanup_if_not_ok();
1522
1523 ast_n_arg = mdata_vector_get(
1524 &(parser->ast), n->ast_idx_children[arg_idx],
1525 struct MLISP_AST_NODE );
1526
1527 /* Pull out the arg name from the strpool so we can call env_set(). */
1528 key_tmp_h = mdata_strpool_extract(
1529 &(parser->strpool), ast_n_arg->token_idx );
1530 /* TODO: Handle this gracefully. */
1531 assert( (MAUG_MHANDLE)NULL != key_tmp_h );
1532
1533 maug_mlock( key_tmp_h, key_tmp );
1534 maug_cleanup_if_null_lock( char*, key_tmp );
1535
1536 retval = mlisp_env_set(
1537 exec, key_tmp, 0, stack_n_arg.type, &(stack_n_arg.value), 0, 0 );
1538 maug_cleanup_if_not_ok();
1539
1540 maug_munlock( key_tmp_h, key_tmp );
1541 maug_mfree( key_tmp_h );
1542
1543 arg_idx--;
1544 }
1545
1546cleanup:
1547
1548 if( NULL != key_tmp ) {
1549 maug_munlock( key_tmp_h, key_tmp );
1550 }
1551
1552 if( (MAUG_MHANDLE)NULL != key_tmp_h ) {
1553 maug_mfree( key_tmp_h );
1554 }
1555
1556 return retval;
1557}
1558
1559/* === */
1560
1561static MERROR_RETVAL _mlisp_reset_child_pcs(
1562 const struct MLISP_PARSER* parser,
1563 size_t n_idx, struct MLISP_EXEC_STATE* exec
1564) {
1565 MERROR_RETVAL retval = MERROR_OK;
1566 size_t* p_child_idx = NULL;
1567 size_t* p_visit_ct = NULL;
1568 struct MLISP_AST_NODE* n = NULL;
1569 size_t i = 0;
1570
1571 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1572 assert( mdata_vector_is_locked( &(parser->ast) ) );
1573
1574 /* Perform the actual reset. */
1575#if MLISP_STEP_TRACE_LVL > 0
1576 debug_printf( MLISP_STEP_TRACE_LVL,
1577 "%u: resetting node " SIZE_T_FMT " child idx to 0", exec->uid, n_idx );
1578#endif /* MLISP_STEP_TRACE_LVL */
1579 p_child_idx = mdata_vector_get( &(exec->per_node_child_idx), n_idx, size_t );
1580 assert( NULL != p_child_idx );
1581 *p_child_idx = 0;
1582
1583#if MLISP_STEP_TRACE_LVL > 0
1584 debug_printf( MLISP_STEP_TRACE_LVL,
1585 "%u: resetting node " SIZE_T_FMT " visit count to 0", exec->uid, n_idx );
1586#endif /* MLISP_STEP_TRACE_LVL */
1587 p_visit_ct = mdata_vector_get( &(exec->per_node_visit_ct), n_idx, size_t );
1588 assert( NULL != p_visit_ct );
1589 *p_visit_ct = 0;
1590
1591 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1592
1593 /* Call reset on all children. */
1594 for( i = 0 ; n->ast_idx_children_sz > i ; i++ ) {
1595 retval = _mlisp_reset_child_pcs( parser, n->ast_idx_children[i], exec );
1596 maug_cleanup_if_not_ok();
1597 }
1598
1599cleanup:
1600
1601 return retval;
1602}
1603
1604/* === */
1605
1606static MERROR_RETVAL _mlisp_reset_lambda(
1607 const struct MLISP_PARSER* parser,
1608 size_t n_idx, struct MLISP_EXEC_STATE* exec
1609) {
1610 MERROR_RETVAL retval = MERROR_OK;
1611
1612#if MLISP_EXEC_TRACE_LVL > 0
1613 debug_printf( MLISP_EXEC_TRACE_LVL,
1614 "%u: resetting lambda " SIZE_T_FMT "...", exec->uid, n_idx );
1615#endif /* MLISP_EXEC_TRACE_LVL */
1616
1617 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1618
1619 /* Move up one env frame. */
1620 assert( !mdata_table_is_locked( &(exec->env[exec->env_select]) ) );
1621 assert( 0 < exec->env_select );
1622 mdata_table_free( &(exec->env[exec->env_select]) );
1623 exec->env_select--;
1624
1625 /* Reset per-node program counters. */
1626 retval = _mlisp_reset_child_pcs( parser, n_idx, exec );
1627
1628 return retval;
1629}
1630
1631/* === */
1632
1633/* This is internal-only and should only be called from _mlisp_step_iter()! */
1634static MERROR_RETVAL _mlisp_step_lambda(
1635 struct MLISP_PARSER* parser,
1636 size_t n_idx, struct MLISP_EXEC_STATE* exec
1637) {
1638 MERROR_RETVAL retval = MERROR_OK;
1639 size_t* p_lambda_child_idx = NULL;
1640#if MLISP_STEP_TRACE_LVL > 0
1641 size_t* p_args_child_idx = NULL;
1642#endif /* MLISP_STEP_TRACE_LVL */
1643 struct MLISP_AST_NODE* n = NULL;
1644 size_t* p_n_last_lambda = NULL;
1645 ssize_t append_retval = 0;
1646
1647#ifdef MLISP_DEBUG_TRACE
1648 exec->trace[exec->trace_depth++] = n_idx;
1649 assert( exec->trace_depth <= MLISP_DEBUG_TRACE );
1650#endif /* MLISP_DEBUG_TRACE */
1651
1652 /* n_idx is the node of this lambda. */
1653 mdata_vector_lock( &(exec->lambda_trace) );
1654 p_n_last_lambda = mdata_vector_get_last( &(exec->lambda_trace), size_t );
1655 mdata_vector_unlock( &(exec->lambda_trace) );
1656 if( NULL != p_n_last_lambda && n_idx == *p_n_last_lambda ) {
1657 /* This is a recursive call, so get rid of the lambda context so we can
1658 * replace it with a new one afterwards.
1659 */
1660#if MLISP_STEP_TRACE_LVL > 0
1661 debug_printf( MLISP_STEP_TRACE_LVL, "%u: TRACE TAIL TIME!", exec->uid );
1662#endif /* MLISP_STEP_TRACE_LVL */
1663 /*
1664 assert(
1665 !mdata_table_is_locked( &(exec->env) ) );
1666 */
1667 _mlisp_reset_lambda( parser, n_idx, exec );
1668 retval = mdata_vector_remove_last( &(exec->lambda_trace) );
1669 maug_cleanup_if_not_ok();
1670 }
1671
1672#if MLISP_STEP_TRACE_LVL > 0
1673 debug_printf( MLISP_STEP_TRACE_LVL,
1674 "%u: xvxvxvxvxvxvx STEP LAMBDA " SIZE_T_FMT " xvxvxvxvxvx",
1675 exec->uid, n_idx );
1676#endif /* MLISP_STEP_TRACE_LVL */
1677
1678 /* Note that we passed through this lambda to detect tail calls later. */
1679 append_retval = mdata_vector_append(
1680 &(exec->lambda_trace), &n_idx, sizeof( size_t ) );
1681 retval = mdata_retval( append_retval );
1682 maug_cleanup_if_not_ok();
1683
1684 /* Grab the current exec index for the child vector for this node. */
1685 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1686 p_lambda_child_idx = mdata_vector_get(
1687 &(exec->per_node_child_idx), n_idx, size_t );
1688 assert( NULL != p_lambda_child_idx );
1689#if MLISP_STEP_TRACE_LVL > 0
1690 debug_printf( MLISP_STEP_TRACE_LVL,
1691 "%u: lambda node " SIZE_T_FMT " child idx: " SIZE_T_FMT,
1692 exec->uid, n_idx, *p_lambda_child_idx );
1693#endif /* MLISP_STEP_TRACE_LVL */
1694
1695 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1696
1697 /* There needs to be an arg node and an exec node. */
1698 /* TODO: Handle this gracefully. */
1699 assert( 1 < n->ast_idx_children_sz );
1700
1701 if( 0 == *p_lambda_child_idx ) {
1702 /* Parse the args passed to this lambda into the env, temporarily. */
1703
1704 /* Get the current args node child index. */
1705 assert( mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
1706#if MLISP_STEP_TRACE_LVL > 0
1707 p_args_child_idx =
1708#endif /* MLISP_STEP_TRACE_LVL */
1709 mdata_vector_get(
1710 &(exec->per_node_child_idx),
1711 n->ast_idx_children[*p_lambda_child_idx], size_t );
1712#if MLISP_STEP_TRACE_LVL > 0
1713 assert( NULL != p_args_child_idx );
1714 debug_printf( MLISP_STEP_TRACE_LVL,
1715 "%u: child idx for args AST node " SIZE_T_FMT ": " SIZE_T_FMT,
1716 exec->uid, *p_lambda_child_idx, *p_args_child_idx );
1717#endif /* MLISP_STEP_TRACE_LVL */
1718
1719 /* Pop stack into args in the env. */
1720 retval = _mlisp_step_lambda_args(
1721 parser, n->ast_idx_children[*p_lambda_child_idx], exec );
1722 if( MERROR_OK != retval && MERROR_PREEMPT != retval ) {
1723 /* Something bad happened! */
1724 goto cleanup;
1725 }
1726
1727 if( MERROR_OK == retval ) {
1728 /* Set *after-arg* delimiter in env after last arg. */
1729 /*
1730 retval = mlisp_env_set(
1731 parser, exec, "$ARGS_E$", 0, MLISP_TYPE_ARGS_E, &n_idx, NULL, 0 );
1732 maug_cleanup_if_not_ok();
1733 */
1734
1735 /* Increment child idx so we call the exec child on next heartbeat. */
1736 (*p_lambda_child_idx)++;
1737#if MLISP_STEP_TRACE_LVL > 0
1738 debug_printf( MLISP_STEP_TRACE_LVL,
1739 "%u: incremented node " SIZE_T_FMT " child idx to: " SIZE_T_FMT,
1740 exec->uid, n_idx, *p_lambda_child_idx );
1741#endif /* MLISP_STEP_TRACE_LVL */
1742 }
1743
1744 /* Set the error to MERROR_PREEMPT so that caller knows this lambda isn't
1745 * finished executing.
1746 */
1747 retval = MERROR_PREEMPT;
1748
1749 } else if( mlisp_ast_has_ready_children( *p_lambda_child_idx, n ) ) {
1750 /* Dive into first lambda child until we no longer can. */
1751
1752 /*
1753 assert(
1754 !mdata_table_is_locked( &(exec->env) ) );
1755 */
1756 assert(
1757 NULL == exec->global_env ||
1758 !mdata_table_is_locked( exec->global_env ) );
1759
1760 retval = _mlisp_step_iter(
1761 parser, n->ast_idx_children[*p_lambda_child_idx], exec );
1762
1763 retval = _mlisp_preempt(
1764 retval, "lambda", parser, n_idx, exec, (*p_lambda_child_idx) + 1 );
1765
1766 } else {
1767 /* No more children to execute! */
1768 /* assert(
1769 !mdata_table_is_locked( &(exec->env) ) ); */
1770 assert(
1771 NULL == exec->global_env ||
1772 !mdata_table_is_locked( exec->global_env ) );
1773 _mlisp_reset_lambda( parser, n_idx, exec );
1774 }
1775
1776 /* TODO: If MERROR_PREEMPT is not returned, remove args_s and args_e? */
1777
1778cleanup:
1779
1780#if MLISP_STEP_TRACE_LVL > 0
1781 debug_printf( MLISP_STEP_TRACE_LVL,
1782 "%u: xvxvxvxvxvxvx END STEP LAMBDA " SIZE_T_FMT " xvxvxvxvxvx",
1783 exec->uid, n_idx );
1784#endif /* MLISP_STEP_TRACE_LVL */
1785
1786 /* Cleanup the passthrough note for this heartbeat. */
1787 mdata_vector_remove_last( &(exec->lambda_trace) );
1788
1789 return retval;
1790}
1791
1792/* === */
1793
1794static MERROR_RETVAL _mlisp_stack_cleanup(
1795 struct MLISP_PARSER* parser, size_t n_idx, struct MLISP_EXEC_STATE* exec
1796) {
1797 MERROR_RETVAL retval = MERROR_OK;
1798 ssize_t i = 0;
1799 struct MLISP_STACK_NODE o;
1800
1801 /* Pop elements off the stack until we hit the matching begin frame. */
1802 i = mdata_vector_ct( &(exec->stack) ) - 1;
1803 while( 0 <= i ) {
1804
1805 retval = mlisp_stack_pop( exec, &o );
1806 maug_cleanup_if_not_ok();
1807
1808 if( MLISP_TYPE_BEGIN == o.type && n_idx == o.value.begin ) {
1809 break;
1810 }
1811
1812 i--;
1813 }
1814
1815cleanup:
1816
1817 return retval;
1818}
1819
1820/* === */
1821
1826static MERROR_RETVAL _mlisp_eval_token_strpool(
1827 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec,
1828 size_t token_idx, size_t token_sz, struct MLISP_ENV_NODE* e_out
1829) {
1830 MERROR_RETVAL retval = MERROR_OK;
1831 struct MLISP_ENV_NODE* p_e = NULL;
1832 char* strpool_token = NULL;
1833
1834 /* Make sure we're sharing env context with our caller! */
1835 /* assert(
1836 mdata_table_is_locked( &(exec->env) ) ); */
1837 assert( /* Also make sure we're sharing ctx for global env if present! */
1838 NULL == exec->global_env ||
1839 mdata_table_is_locked( exec->global_env ) );
1840
1841 mdata_strpool_lock( &(parser->strpool) );
1842
1843 /* TODO: Use exec_state strpool. */
1844 strpool_token = mdata_strpool_get( &(parser->strpool), token_idx );
1845 assert( NULL != strpool_token );
1846
1847#if MLISP_EXEC_TRACE_LVL > 0
1848 debug_printf( MLISP_EXEC_TRACE_LVL,
1849 "%u: eval token: \"%s\" (strlen: " SIZE_T_FMT "r/" SIZE_T_FMT "d)",
1850 exec->uid, strpool_token, token_sz, maug_strlen( strpool_token ) );
1851#endif /* MLISP_EXEC_TRACE_LVL */
1852 if( 0 == maug_strncmp( strpool_token, "begin", token_sz + 1 ) ) {
1853 /* Fake env node e to signal step_iter() to place/cleanup stack frame. */
1854 e_out->type = MLISP_TYPE_BEGIN;
1855
1856 } else if( NULL != (p_e = mlisp_env_get( exec, strpool_token ) ) ) {
1857 /* A literal found in the environment. */
1858#if MLISP_EXEC_TRACE_LVL > 0
1859 debug_printf( MLISP_EXEC_TRACE_LVL, "%u: found %s in env!",
1860 exec->uid, strpool_token );
1861#endif /* MLISP_EXEC_TRACE_LVL */
1862
1863 /* Copy onto native stack so we can unlock env in case this is a
1864 * callback that needs to execute. */
1865 memcpy( e_out, p_e, sizeof( struct MLISP_ENV_NODE ) );
1866 p_e = NULL;
1867
1868 } else if( maug_is_num( strpool_token, token_sz, 10, 1 ) ) {
1869 /* Fake env node e from a numeric literal. */
1870#if MLISP_EXEC_TRACE_LVL > 0
1871 debug_printf( MLISP_EXEC_TRACE_LVL,
1872 "%u: did not find %s in env, but it is a number...",
1873 exec->uid, strpool_token );
1874#endif /* MLISP_EXEC_TRACE_LVL */
1875 e_out->value.integer = maug_atos32( strpool_token, token_sz );
1876 e_out->type = MLISP_TYPE_INT;
1877
1878 } else if( maug_is_float( strpool_token, token_sz ) ) {
1879#if MLISP_EXEC_TRACE_LVL > 0
1880 debug_printf( MLISP_EXEC_TRACE_LVL,
1881 "%u: did not find %s in env, but it is a float...",
1882 exec->uid, strpool_token );
1883#endif /* MLISP_EXEC_TRACE_LVL */
1884 /* Fake env node e from a floating point numeric literal. */
1885 e_out->value.floating = maug_atof( strpool_token, token_sz );
1886 e_out->type = MLISP_TYPE_FLOAT;
1887
1888 } else {
1889#if MLISP_EXEC_TRACE_LVL > 0
1890 error_printf( "%u: could not make sense of token: %s",
1891 exec->uid, strpool_token );
1892#endif /* MLISP_EXEC_TRACE_LVL */
1893
1894 }
1895
1896cleanup:
1897
1898 if( mdata_strpool_is_locked( &(parser->strpool) ) ) {
1899 mdata_strpool_unlock( &(parser->strpool) );
1900 }
1901
1902#if MLISP_EXEC_TRACE_LVL > 0
1903 debug_printf( MLISP_EXEC_TRACE_LVL, "%u: eval token complete!",
1904 exec->uid );
1905#endif /* MLISP_EXEC_TRACE_LVL */
1906
1907 return retval;
1908}
1909
1910static MERROR_RETVAL _mlisp_step_iter(
1911 struct MLISP_PARSER* parser,
1912 size_t n_idx, struct MLISP_EXEC_STATE* exec
1913) {
1914 MERROR_RETVAL retval = MERROR_OK;
1915 struct MLISP_ENV_NODE e;
1916 struct MLISP_AST_NODE* n = NULL;
1917 size_t* p_visit_ct = NULL;
1918 mlisp_env_cb_t e_cb = NULL;
1919 uint8_t e_flags = 0;
1920 mlisp_lambda_t e_lambda = 0;
1921 int8_t env_iter = 0;
1922
1923 /* With -O2, gcc seems to sometimes(?) push an arbitrary integer to the
1924 * stack, unless we use this variable force it to pass the literal index.
1925 * This *seems* to resolve the issue.
1926 */
1927 volatile mdata_strpool_idx_t node_strpool_idx = 0;
1928
1929#ifdef MLISP_DEBUG_TRACE
1930 exec->trace[exec->trace_depth++] = n_idx;
1931 assert( exec->trace_depth <= MLISP_DEBUG_TRACE );
1932#endif /* MLISP_DEBUG_TRACE */
1933
1934 n = mdata_vector_get( &(parser->ast), n_idx, struct MLISP_AST_NODE );
1935
1936 assert( mdata_vector_is_locked( &(exec->per_node_visit_ct) ) );
1937 p_visit_ct = mdata_vector_get(
1938 &(exec->per_node_visit_ct), n_idx, size_t );
1939 assert( NULL != p_visit_ct );
1940 (*p_visit_ct)++;
1941#if MLISP_STEP_TRACE_LVL > 0
1942 debug_printf( MLISP_STEP_TRACE_LVL,
1943 "%u: visit count for AST node " SIZE_T_FMT ": " SIZE_T_FMT,
1944 exec->uid, n_idx, *p_visit_ct );
1945#endif /* MLISP_STEP_TRACE_LVL */
1946
1947 /* Push a stack frame marker on the first visit to a BEGIN node. */
1948 if(
1949 MLISP_AST_FLAG_BEGIN == (MLISP_AST_FLAG_BEGIN & n->flags) &&
1950 1 == *p_visit_ct
1951 ) {
1952 /* Push a stack frame on first visit. */
1953 retval = _mlisp_stack_push_mlisp_begin_t( exec, n_idx );
1954 maug_cleanup_if_not_ok();
1955 }
1956
1957 if(
1958 MERROR_OK !=
1959 (retval = _mlisp_step_iter_children( parser, n_idx, exec ))
1960 ) {
1961 goto cleanup;
1962 }
1963
1964 /* Check for special types like lambda, that are lazily evaluated. */
1965 if( MLISP_AST_FLAG_LAMBDA == (MLISP_AST_FLAG_LAMBDA & n->flags) ) {
1966 /* Push the lambda to the stack so that the "define" above it can
1967 * grab it and associate it with the env.
1968 */
1969 /* TODO: Assert node above it is a define! */
1970 mlisp_stack_push( exec, n_idx, mlisp_lambda_t );
1971 goto cleanup;
1972 }
1973
1974 /* Now that the children have been evaluated above, evaluate this node.
1975 * Assume all the previously called children are now on the stack.
1976 */
1977
1978 /* Lock the env so we can grab the token from it and evalauate it below
1979 * in one swoop without an unlock.
1980 */
1981 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
1982#if MLISP_LOCK_TRACE_LVL > 0
1983 debug_printf( MLISP_LOCK_TRACE_LVL,
1984 "%u: locking local env %d...", exec->uid, env_iter );
1985#endif /* MLISP_LOCK_TRACE_LVL */
1986 mdata_table_lock( &(exec->env[env_iter]) );
1987 }
1988
1989 assert(
1990 NULL == exec->global_env || !mdata_table_is_locked( exec->global_env ) );
1991 if( NULL != exec->global_env ) {
1992 mdata_table_lock( exec->global_env );
1993 }
1994
1995 /* Grab the token for this node and figure out what it is. */
1996 retval = _mlisp_eval_token_strpool(
1997 parser, exec, n->token_idx, n->token_sz, &e );
1998 maug_cleanup_if_not_ok();
1999
2000 /* Prepare to step. */
2001
2002#if MLISP_STEP_TRACE_LVL > 0
2003 debug_printf( MLISP_STEP_TRACE_LVL, "%u: acting on evaluated token...",
2004 exec->uid );
2005#endif /* MLISP_STEP_TRACE_LVL */
2006
2007 /* Put the token or its result (if callable) on the stack. */
2008# define _MLISP_TYPE_TABLE_ENVE( idx, ctype, name, const_name, fmt ) \
2009 } else if( MLISP_TYPE_ ## const_name == e.type ) { \
2010 debug_printf( MLISP_EXEC_TRACE_LVL, \
2011 "%u: pushing env: " fmt " to stack...", \
2012 exec->uid, e.value.name ); \
2013 retval = _mlisp_stack_push_ ## ctype( exec, e.value.name ); \
2014 maug_cleanup_if_not_ok();
2015
2016 if( MLISP_EXEC_FLAG_DEF_TERM == (MLISP_EXEC_FLAG_DEF_TERM & exec->flags) ) {
2017 /* Avoid a deadlock when *re*-assigning terms caused by term being
2018 * evaluated before it is defined.
2019 */
2020#if MLISP_EXEC_TRACE_LVL > 0
2021 debug_printf( MLISP_EXEC_TRACE_LVL,
2022 "%u: special case! pushing literal to stack: " SSIZE_T_FMT,
2023 exec->uid, n->token_idx );
2024#endif /* MLISP_EXEC_TRACE_LVL */
2025 node_strpool_idx = n->token_idx;
2026 retval = _mlisp_stack_push_mdata_strpool_idx_t( exec, node_strpool_idx );
2027 maug_cleanup_if_not_ok();
2028 } else if( MLISP_TYPE_BEGIN == e.type ) {
2029 /* Cleanup the stack that's been pushed by children since this BEGIN's
2030 * initial visit.
2031 */
2032#if MLISP_STEP_TRACE_LVL > 0
2033 debug_printf( MLISP_STEP_TRACE_LVL,
2034 "%u: rewinding stack for begin on node " SSIZE_T_FMT,
2035 exec->uid, n_idx );
2036#endif /* MLISP_STEP_TRACE_LVL */
2037 retval = _mlisp_stack_cleanup( parser, n_idx, exec );
2038 maug_cleanup_if_not_ok();
2039
2040 /* Push a replacement BEGIN that can be caught later and throw an
2041 * MERROR_RESET.
2042 */
2043 retval = _mlisp_stack_push_mlisp_begin_t( exec, n_idx );
2044 maug_cleanup_if_not_ok();
2045
2046 } else if( MLISP_TYPE_CB == e.type ) {
2047 /* This is a special case... rather than pushing the callback, *execute*
2048 * it and let it push its result to the stack. This will create a
2049 * redundant case below, but that can't be helped...
2050 */
2051
2052#if MLISP_EXEC_TRACE_LVL > 0
2053 debug_printf( MLISP_EXEC_TRACE_LVL,
2054 "%u: special case! executing callback: %p", exec->uid, e_cb );
2055#endif /* MLISP_EXEC_TRACE_LVL */
2056
2057 /* Unlock the env so the callback below can use it if needed. */
2058 e_cb = e.value.cb;
2059 e_flags = e.flags;
2060 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2061 mdata_table_unlock( &(exec->env[env_iter]) );
2062 }
2063 if( NULL != exec->global_env ) {
2064 mdata_table_unlock( exec->global_env );
2065 }
2066
2067 retval = e_cb(
2068 parser, exec, n_idx, n->ast_idx_children_sz, NULL, e_flags );
2069
2070 /* Relock it for the benefit of the unlock in cleanup. */
2071 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2072 mdata_table_lock( &(exec->env[env_iter]) );
2073 }
2074 if( NULL != exec->global_env ) {
2075 mdata_table_lock( exec->global_env );
2076 }
2077
2078 } else if( MLISP_TYPE_LAMBDA == e.type ) {
2079
2080#if MLISP_EXEC_TRACE_LVL > 0
2081 debug_printf( MLISP_EXEC_TRACE_LVL,
2082 "%u: special case! executing lambda...", exec->uid );
2083#endif /* MLISP_EXEC_TRACE_LVL */
2084
2085 /* Create a "portal" into the lambda. The execution chain stays pointing
2086 * to this lambda-call node, but _mlisp_step_lambda() returns
2087 * MERROR_PREEMPT up the chain for subsequent heartbeats, until lambda is
2088 * done.
2089 */
2090 e_lambda = e.value.lambda;
2091 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2092 mdata_table_unlock( &(exec->env[env_iter]) );
2093 }
2094 if( NULL != exec->global_env ) {
2095 mdata_table_unlock( exec->global_env );
2096 }
2097
2098 retval = _mlisp_step_lambda( parser, e_lambda, exec );
2099
2100 /* Relock it for the benefit of the unlock in cleanup. */
2101 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2102 mdata_table_lock( &(exec->env[env_iter]) );
2103 }
2104 if( NULL != exec->global_env ) {
2105 mdata_table_lock( exec->global_env );
2106 }
2107
2108 MLISP_TYPE_TABLE( _MLISP_TYPE_TABLE_ENVE )
2109 } else {
2110#if MLISP_EXEC_TRACE_LVL > 0
2111 debug_printf( MLISP_EXEC_TRACE_LVL, "pushing literal into stack" );
2112#endif /* !MLISP_EXEC_TRACE_LVL */
2113 retval = _mlisp_stack_push_mdata_strpool_idx_t( exec, n->token_idx );
2114 maug_cleanup_if_not_ok();
2115 }
2116
2117cleanup:
2118
2119 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2120 mdata_table_unlock( &(exec->env[env_iter]) );
2121 }
2122
2123 if( NULL != exec->global_env ) {
2124 mdata_table_unlock( exec->global_env );
2125 }
2126
2127 return retval;
2128}
2129
2130/* === */
2131
2132static MERROR_RETVAL _mlisp_count_builtins_iter(
2133 const struct MDATA_TABLE_KEY* key, void* data, size_t data_sz,
2134 void* cb_data, size_t cb_data_sz, size_t idx
2135) {
2136 MERROR_RETVAL retval = MERROR_OK;
2137 struct MLISP_ENV_NODE* e = (struct MLISP_ENV_NODE*)data;
2138 ssize_t* p_builtins = (ssize_t*)cb_data;
2139
2140 if( MLISP_ENV_FLAG_BUILTIN == (MLISP_ENV_FLAG_BUILTIN & e->flags) ) {
2141 (*p_builtins)++;
2142 }
2143
2144 return retval;
2145}
2146
2147/* === */
2148
2149ssize_t mlisp_count_builtins( struct MLISP_EXEC_STATE* exec ) {
2150 MERROR_RETVAL retval = MERROR_OK;
2151 ssize_t builtins = 0;
2152 int autolock = 0;
2153
2154 if( 0 == mdata_table_ct( &(exec->env[0]) ) ) {
2155 goto cleanup;
2156 }
2157
2158 if( !mdata_table_is_locked( &(exec->env[0]) ) ) {
2159 mdata_table_lock( &(exec->env[0]) );
2160 autolock = 1;
2161 }
2162
2163 retval = mdata_table_iter(
2164 &(exec->env[0]), _mlisp_count_builtins_iter, &builtins, 0 );
2165
2166cleanup:
2167
2168 if( MERROR_OK != retval ) {
2169 builtins = merror_retval_to_sz( retval );
2170 }
2171
2172 if( autolock ) {
2173 mdata_table_unlock( &(exec->env[0]) );
2174 }
2175
2176 return builtins;
2177}
2178
2179/* === */
2180
2181MERROR_RETVAL mlisp_check_state(
2182 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec
2183) {
2184 MERROR_RETVAL retval = MERROR_OK;
2185
2186 if( !mlisp_check_ast( parser ) ) {
2187 error_printf( "no valid AST present; could not exec!" );
2188 retval = MERROR_EXEC;
2189 goto cleanup;
2190 }
2191
2192 if(
2193 MLISP_EXEC_FLAG_INITIALIZED != (exec->flags & MLISP_EXEC_FLAG_INITIALIZED)
2194 ) {
2195 retval = MERROR_EXEC;
2196 goto cleanup;
2197 }
2198
2199cleanup:
2200
2201 return retval;
2202}
2203
2204/* === */
2205
2207 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec
2208) {
2209 MERROR_RETVAL retval = MERROR_OK;
2210#ifdef MLISP_DEBUG_TRACE
2211 size_t i = 0;
2212 char trace_str[MLISP_DEBUG_TRACE * 5];
2213 maug_ms_t ms_start = 0;
2214 maug_ms_t ms_end = 0;
2215
2216 ms_start = retroflat_get_ms();
2217#endif /* MLISP_DEBUG_TRACE */
2218
2219#if MLISP_STEP_TRACE_LVL > 0
2220 debug_printf( MLISP_STEP_TRACE_LVL, "%u: heartbeat start", exec->uid );
2221#endif /* MLISP_STEP_TRACE_LVL */
2222
2223 /* These can remain locked for the whole step, as they're never added or
2224 * removed.
2225 */
2226 assert( !mdata_vector_is_locked( &(exec->per_node_child_idx) ) );
2227 assert( !mdata_vector_is_locked( &(exec->per_node_visit_ct) ) );
2228 assert( !mdata_vector_is_locked( &(parser->ast) ) );
2229 mdata_vector_lock( &(exec->per_node_child_idx) );
2230 mdata_vector_lock( &(exec->per_node_visit_ct) );
2231 mdata_vector_lock( &(parser->ast) );
2232
2233 /* Disable transient flags. */
2234 exec->flags &= MLISP_EXEC_FLAG_TRANSIENT_MASK;
2235 assert( 0 == mdata_vector_ct( &(exec->lambda_trace) ) );
2236
2237#ifdef MLISP_DEBUG_TRACE
2238 exec->trace_depth = 0;
2239#endif /* MLISP_DEBUG_TRACE */
2240
2241 /* Find next unevaluated symbol. */
2242 retval = _mlisp_step_iter( parser, 0, exec );
2243 if( MERROR_PREEMPT == retval ) {
2244 /* There's still more to execute. */
2245 retval = MERROR_OK;
2246 } else if( MERROR_OK == retval ) {
2247 /* The last node executed completely. */
2248#if MLISP_EXEC_TRACE_LVL > 0
2249 debug_printf( MLISP_EXEC_TRACE_LVL,
2250 "%u: execution terminated successfully", exec->uid );
2251#endif /* MLISP_EXEC_TRACE_LVL */
2252 retval = MERROR_EXEC; /* Signal the caller: we're out of instructions! */
2253#if MLISP_EXEC_TRACE_LVL > 0
2254 } else {
2255 debug_printf( MLISP_EXEC_TRACE_LVL,
2256 "%u: execution terminated with retval: %d", exec->uid, retval );
2257#endif /* MLISP_EXEC_TRACE_LVL */
2258 }
2259
2260#ifdef MLISP_DEBUG_TRACE
2261 ms_end = retroflat_get_ms();
2262
2263 maug_mzero( trace_str, MLISP_DEBUG_TRACE * 5 );
2264 for( i = 0 ; exec->trace_depth > i ; i++ ) {
2265 maug_snprintf(
2266 &(trace_str[maug_strlen( trace_str )]),
2267 (MLISP_DEBUG_TRACE * 5) - maug_strlen( trace_str ),
2268 SIZE_T_FMT ", ", exec->trace[i] );
2269 }
2270#if MLISP_STEP_TRACE_LVL > 0
2271 debug_printf( MLISP_STEP_TRACE_LVL,
2272 "%u: " MLISP_TRACE_SIGIL " HBEXEC (%u): %s",
2273 exec->uid, ms_end - ms_start, trace_str );
2274#endif /* MLISP_STEP_TRACE_LVL */
2275#endif /* MLISP_DEBUG_TRACE */
2276
2277cleanup:
2278
2279#if MLISP_STEP_TRACE_LVL > 0
2280 debug_printf( MLISP_STEP_TRACE_LVL,
2281 "%u: heartbeat end: %x", exec->uid, retval );
2282#endif /* MLISP_STEP_TRACE_LVL */
2283
2284 assert( mdata_vector_is_locked( &(parser->ast) ) );
2285 mdata_vector_unlock( &(parser->ast) );
2286 mdata_vector_unlock( &(exec->per_node_visit_ct) );
2287 mdata_vector_unlock( &(exec->per_node_child_idx) );
2288
2289 return retval;
2290}
2291
2292/* === */
2293
2295 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec,
2296 const char* lambda
2297) {
2298 struct MLISP_ENV_NODE* e = NULL;
2299 MERROR_RETVAL retval = MERROR_OK;
2300 uint8_t autolock[MLISP_EXEC_ENV_FRAME_CT_MAX];
2301 mlisp_lambda_t lambda_idx = 0;
2302 struct MLISP_AST_NODE* n = NULL;
2303 int8_t env_iter = 0;
2304
2305 if( MERROR_OK != mlisp_check_state( parser, exec ) ) {
2306 error_printf( "mlisp not ready!" );
2307 retval = MERROR_EXEC;
2308 goto cleanup;
2309 }
2310
2311 retval = _mlisp_autolock( parser, exec, 0xff, autolock );
2312 maug_cleanup_if_not_ok();
2313
2314 /* Find the AST node for the lambda. */
2315 e = mlisp_env_get( exec, lambda );
2316 if( NULL == e ) {
2317 error_printf( "lambda \"%s\" not found!", lambda );
2318 retval = MERROR_OVERFLOW;
2319 goto cleanup;
2320 }
2321 lambda_idx = e->value.lambda;
2322
2323 /* Autounlock just env so _mlisp_step_lambda() works. */
2324 /* We use autolock with the env minimally to avoid passing around bad
2325 * pointers.
2326 */
2327 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2328 if( MLISP_AUTOLOCK_EXEC_ENV == (MLISP_AUTOLOCK_EXEC_ENV & autolock[0]) ) {
2329 mdata_table_unlock( &(exec->env[env_iter]) );
2330 autolock[env_iter] &= ~MLISP_AUTOLOCK_EXEC_ENV;
2331 }
2332 }
2333 if(
2334 MLISP_AUTOLOCK_GLOBAL_ENV == (MLISP_AUTOLOCK_GLOBAL_ENV & autolock[0])
2335 ) {
2336 mdata_table_unlock( exec->global_env );
2337 autolock[0] &= ~MLISP_AUTOLOCK_GLOBAL_ENV;
2338 }
2339
2340#if MLISP_STEP_TRACE_LVL > 0
2341 debug_printf( MLISP_STEP_TRACE_LVL, "%u: lambda \"%s\" is AST node idx %ld",
2342 exec->uid, lambda, lambda_idx );
2343#endif /* MLISP_STEP_TRACE_LVL */
2344
2345 n = mdata_vector_get( &(parser->ast), lambda_idx, struct MLISP_AST_NODE );
2346 if( MLISP_AST_FLAG_LAMBDA != (MLISP_AST_FLAG_LAMBDA & n->flags) ) {
2347 error_printf( "invalid node %d: not a lambda!", lambda_idx );
2348 retval = MERROR_EXEC;
2349 goto cleanup;
2350 }
2351
2352 /* Jump execution to the lambda on next iter. */
2353 retval = _mlisp_step_lambda( parser, lambda_idx, exec );
2354
2355cleanup:
2356
2357 _mlisp_autounlock( parser, exec, autolock );
2358
2359 return retval;
2360}
2361
2362/* === */
2363
2364MERROR_RETVAL mlisp_exec_add_env_builtins(
2365 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec
2366) {
2367 MERROR_RETVAL retval = MERROR_OK;
2368
2369 retval = mlisp_env_set(
2370 exec, "gdefine", 7, MLISP_TYPE_CB, _mlisp_env_cb_define,
2371 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_DEFINE_GLOBAL );
2372 maug_cleanup_if_not_ok();
2373
2374 retval = mlisp_env_set(
2375 exec, "and", 3, MLISP_TYPE_CB, _mlisp_env_cb_ano,
2376 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_ANO_AND );
2377 maug_cleanup_if_not_ok();
2378
2379 retval = mlisp_env_set(
2380 exec, "or", 2, MLISP_TYPE_CB, _mlisp_env_cb_ano,
2381 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_ANO_OR );
2382 maug_cleanup_if_not_ok();
2383
2384#ifndef MAUG_NO_RETRO
2385/* TODO: Call this in retroflat in line with dependency guidelines. */
2386 retval = mlisp_env_set(
2387 exec, "random", 6, MLISP_TYPE_CB, _mlisp_env_cb_random,
2388 0, MLISP_ENV_FLAG_BUILTIN );
2389 maug_cleanup_if_not_ok();
2390#endif /* !MAUG_NO_RETRO */
2391
2392 retval = mlisp_env_set(
2393 exec, "if", 2, MLISP_TYPE_CB, _mlisp_env_cb_if,
2394 0, MLISP_ENV_FLAG_BUILTIN );
2395 maug_cleanup_if_not_ok();
2396
2397 retval = mlisp_env_set(
2398 exec, "debug", 5, MLISP_TYPE_CB, _mlisp_env_cb_debug,
2399 0, MLISP_ENV_FLAG_BUILTIN );
2400 maug_cleanup_if_not_ok();
2401
2402 retval = mlisp_env_set(
2403 exec, "define", 6, MLISP_TYPE_CB, _mlisp_env_cb_define,
2404 0, MLISP_ENV_FLAG_BUILTIN );
2405 maug_cleanup_if_not_ok();
2406
2407 retval = mlisp_env_set(
2408 exec, "*", 1, MLISP_TYPE_CB, _mlisp_env_cb_arithmetic,
2409 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_ARI_MUL );
2410 maug_cleanup_if_not_ok();
2411
2412 retval = mlisp_env_set(
2413 exec, "+", 1, MLISP_TYPE_CB, _mlisp_env_cb_arithmetic,
2414 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_ARI_ADD );
2415 maug_cleanup_if_not_ok();
2416
2417 retval = mlisp_env_set(
2418 exec, "/", 1, MLISP_TYPE_CB, _mlisp_env_cb_arithmetic,
2419 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_ARI_DIV );
2420 maug_cleanup_if_not_ok();
2421
2422 retval = mlisp_env_set(
2423 exec, "%", 1, MLISP_TYPE_CB, _mlisp_env_cb_arithmetic,
2424 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_ARI_MOD );
2425 maug_cleanup_if_not_ok();
2426
2427 retval = mlisp_env_set(
2428 exec, "<", 1, MLISP_TYPE_CB, _mlisp_env_cb_cmp,
2429 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_CMP_LT );
2430 maug_cleanup_if_not_ok();
2431
2432 retval = mlisp_env_set(
2433 exec, ">", 1, MLISP_TYPE_CB, _mlisp_env_cb_cmp,
2434 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_CMP_GT );
2435 maug_cleanup_if_not_ok();
2436
2437 retval = mlisp_env_set(
2438 exec, "=", 1, MLISP_TYPE_CB, _mlisp_env_cb_cmp,
2439 0, MLISP_ENV_FLAG_BUILTIN | MLISP_ENV_FLAG_CMP_EQ );
2440 maug_cleanup_if_not_ok();
2441
2442cleanup:
2443
2444 return retval;
2445}
2446
2447/* === */
2448
2449MERROR_RETVAL mlisp_exec_init(
2450 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec, uint8_t flags
2451) {
2452 MERROR_RETVAL retval = MERROR_OK;
2453 ssize_t append_retval = 0;
2454 size_t zero = 0;
2455 int16_t null_val = 0;
2456
2457 assert( 0 == exec->flags );
2458
2459 maug_mzero( exec, sizeof( struct MLISP_EXEC_STATE ) );
2460
2461 exec->flags = flags;
2462 exec->uid = g_mlispe_last_uid++;
2463
2464 /* Setup lambda visit stack so it can be locked on first step. */
2465 append_retval = mdata_vector_append(
2466 &(exec->lambda_trace), &zero, sizeof( size_t ) );
2467 if( 0 > append_retval ) {
2468 retval = mdata_retval( append_retval );
2469 }
2470 maug_cleanup_if_not_ok();
2471 mdata_vector_remove_last( &(exec->lambda_trace) );
2472
2473 /* Define a constant so that the table is never empty, which makes things
2474 * run more smoothly.
2475 */
2476 retval = mlisp_env_set(
2477 exec, "null", 4, MLISP_TYPE_INT, &null_val, 0, 0 );
2478
2479 /* Create the node PCs. */
2480 append_retval = mdata_vector_append(
2481 &(exec->per_node_child_idx), &zero, sizeof( size_t ) );
2482 if( 0 > append_retval ) {
2483 retval = mdata_retval( append_retval );
2484 }
2485 maug_cleanup_if_not_ok();
2486
2487 /* Make sure there's an exec child node for every AST node. */
2488 while(
2489 mdata_vector_ct( &(exec->per_node_child_idx) ) <=
2490 mdata_vector_ct( &(parser->ast) )
2491 ) {
2492 append_retval = mdata_vector_append( &(exec->per_node_child_idx), &zero,
2493 sizeof( size_t ) );
2494 if( 0 > append_retval ) {
2495 retval = mdata_retval( append_retval );
2496 }
2497 maug_cleanup_if_not_ok();
2498 }
2499
2500 /* Create the node visit counters. */
2501 append_retval = mdata_vector_append(
2502 &(exec->per_node_visit_ct), &zero, sizeof( size_t ) );
2503 if( 0 > append_retval ) {
2504 retval = mdata_retval( append_retval );
2505 }
2506 maug_cleanup_if_not_ok();
2507
2508 /* Make sure there's an exec visit count for every AST node. */
2509 while(
2510 mdata_vector_ct( &(exec->per_node_visit_ct) ) <=
2511 mdata_vector_ct( &(parser->ast) )
2512 ) {
2513 append_retval = mdata_vector_append( &(exec->per_node_visit_ct), &zero,
2514 sizeof( size_t ) );
2515 if( 0 > append_retval ) {
2516 retval = mdata_retval( append_retval );
2517 }
2518 maug_cleanup_if_not_ok();
2519 }
2520
2521 exec->flags |= MLISP_EXEC_FLAG_INITIALIZED;
2522
2523 /* Setup initial env. */
2524
2525 retval = mlisp_exec_add_env_builtins( parser, exec );
2526
2527cleanup:
2528
2529 if( MERROR_OK != retval ) {
2530 error_printf( "mlisp exec initialization failed: %d", retval );
2531 }
2532
2533 return retval;
2534}
2535
2536/* === */
2537
2539 struct MLISP_PARSER* parser, struct MLISP_EXEC_STATE* exec,
2540 struct MDATA_TABLE* global_env
2541) {
2542 MERROR_RETVAL retval = MERROR_OK;
2543 int16_t null_val = 0;
2544
2545 exec->global_env = global_env;
2546
2547 if( 0 == mdata_table_ct( global_env ) ) {
2548 /* Things get very wonky if the env is completely empty due to how empty
2549 * vectors respond to locking. This is a simple way of working around
2550 * that rather than adding a lot of special cases!
2551 */
2552 retval = mlisp_env_set(
2553 exec, "null", 4, MLISP_TYPE_INT, &null_val, 1, 0 );
2554 }
2555
2556 return retval;
2557}
2558
2559/* === */
2560
2561void mlisp_exec_free( struct MLISP_EXEC_STATE* exec ) {
2562 int8_t env_iter = 0;
2563
2564#if MLISP_EXEC_TRACE_LVL > 0
2565 debug_printf( MLISP_EXEC_TRACE_LVL,
2566 "%u: destroying exec (stack: " SIZE_T_FMT ", env: " SIZE_T_FMT ")...",
2567 exec->uid,
2568 mdata_vector_ct( &(exec->stack) ),
2569 mdata_table_ct( &(exec->env[exec->env_select]) ) );
2570#endif /* MLISP_EXEC_TRACE_LVL */
2571 mdata_vector_free( &(exec->per_node_child_idx) );
2572 mdata_vector_free( &(exec->per_node_visit_ct) );
2573 mdata_vector_free( &(exec->stack) );
2574 for( env_iter = exec->env_select ; 0 <= env_iter ; env_iter-- ) {
2575 mdata_table_free( &(exec->env[env_iter]) );
2576 }
2577 mdata_vector_free( &(exec->lambda_trace) );
2578 exec->flags = 0;
2579#if MLISP_EXEC_TRACE_LVL > 0
2580 debug_printf( MLISP_EXEC_TRACE_LVL, "exec destroyed!" );
2581#endif /* MLISP_EXEC_TRACE_LVL */
2582}
2583
2584/* === */
2585
2586MERROR_RETVAL mlisp_deserialize_prepare_EXEC_STATE(
2587 struct MLISP_EXEC_STATE* exec, size_t i
2588) {
2589 MERROR_RETVAL retval = MERROR_OK;
2590 /* TODO: Re-add built-in function definitions. */
2591 /* TODO: Provide mechanism for program using maug to re-add function
2592 * definitions!
2593 */
2594 return retval;
2595}
2596
2597#else
2598
2599# define MLISP_PSTATE_TABLE_CONST( name, idx ) \
2600 extern MAUG_CONST uint8_t SEG_MCONST name;
2601
2602MLISP_PARSER_PSTATE_TABLE( MLISP_PSTATE_TABLE_CONST )
2603
2604#ifdef MPARSER_TRACE_NAMES
2605extern MAUG_CONST char* SEG_MCONST gc_mlisp_pstate_names[];
2606#endif /* MPARSER_TRACE_NAMES */
2607
2608#endif /* MLISPE_C */
2609
2610#endif /* !MLISPE_H */
2611
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
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...
#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:133
Definition mdata.h:139
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
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
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