शुद्ध C में LISP दुभाषिया

 #include <assert.h> #include <ctype.h> #include <float.h> #include <stdio.h> #include <stdlib.h> #include <string.h> #define LINE_COMMENT_CHAR ';' #define BLOCK_COMMENT_CHAR1 ';' #define BLOCK_COMMENT_CHAR2 '|' #define LIST_OPEN_BRACE_CHAR '(' #define LIST_CLOSE_BRACE_CHAR ')' #define LIST_DOT_CHAR '.' #define STRING_DELIMITER_CHAR '"' #define STRING_ESCAPE_CHAR '\\' #define NUMBER_PREFIX_CHAR '$' #define NUMBER_FORMAT_HEX_CHAR 'h' #define NUMBER_FORMAT_OCT_CHAR 'o' #define NIL_SYMBOL_STR "_" #define TRUE_SYMBOL_STR "t" #define TRACE_SYMBOL_STR "trace" #define CAR_SYMBOL_STR "@" #define CDR_SYMBOL_STR "%" #define CONS_SYMBOL_STR "^" #define IF_SYMBOL_STR "?" #define LAMBDA_SYMBOL_STR "!" #define MACRO_SYMBOL_STR "#" #define SETQ_SYMBOL_STR "=" #define QUOTE_SYMBOL_STR "'" #define PLUS_SYMBOL_STR "+" #define GREATER_SYMBOL_STR ">" #define FUNCTION_STR_FORMAT "<!%s>" #define MACRO_STR_FORMAT "<#%s>" #define OUT_OF_MEMORY_MSG "out of memory" #define UNEXPECTED_EOF_MSG "unexpected end of file" #define BAD_SYNTAX_MSG "bad syntax" #define NON_FUNC_MACRO_MSG "expression %s is neither a function nor a macro" #define NON_NONEMPTY_LIST_MSG "expression %s is not a nonempty list" #define NON_LIST_MSG "expression %s is not a proper list" #define UNBOUND_SYMBOL_MSG "unbound symbol %s" #define BAD_FORMAL_ARGS_MSG "bad formal arguments %s" #define BAD_ACTUAL_ARGS_MSG "bad actual arguments %s" #define STRING_OVERFLOW_MSG "string size overflow" #define NUMBER_LENGTH_MAX 32 #define SYMBOL_LENGTH_MAX 32 #define STRING_LENGTH_MAX 256 #define S_EXPR_LENGTH_MAX 1024 struct file_pos { char *filename; int line, chr; }; struct l_env; typedef struct s_expr *(*built_in) (struct s_expr*, struct l_env*, struct file_pos*); struct s_expr { enum { DOTTED_PAIR, STRING, SYMBOL, NUMBER, FUNCTION, MACRO, BUILT_IN_FUNCTION, BUILT_IN_MACRO } type; union { struct { struct s_expr *first, *rest; } pair; struct { char *ptr; size_t size; } string; struct { struct s_expr *expr; struct l_env *env; } function; char *symbol; double number; built_in built_in; } u; }; void error(char *message, struct file_pos *pos, char *expr) { if (pos) printf("Error at %s:%d:%d: ", pos->filename, pos->line, pos->chr); else printf("Error: "); if (expr) printf(message, expr); else printf("%s", message); puts(""); exit(1); } void *alloc_mem(size_t size) { void *ptr = malloc(size); if (!ptr) error(OUT_OF_MEMORY_MSG, NULL, NULL); return ptr; } struct s_expr *true_ () { static struct s_expr *expr = NULL; if (!expr) { expr = alloc_mem(sizeof(*expr)); expr->type = SYMBOL; expr->u.symbol = TRUE_SYMBOL_STR; } return expr; } int get_char(FILE *file, struct file_pos *pos) { int chr = getc(file); if (chr == '\n') pos->line++, pos->chr = 1; else if (chr != EOF) pos->chr++; return chr; } int next_char(FILE *file) { int chr = getc(file); ungetc(chr, file); return chr; } int get_significant_char (FILE *file, struct file_pos *pos) { enum { NO_COMMENT, LINE_COMMENT, BLOCK_COMMENT } state = NO_COMMENT; int chr; while (1) { chr = get_char(file, pos); if (state == NO_COMMENT) { if (chr == BLOCK_COMMENT_CHAR1 && next_char(file) == BLOCK_COMMENT_CHAR2) { get_char(file, pos); state = BLOCK_COMMENT; continue; } if (chr == LINE_COMMENT_CHAR) state = LINE_COMMENT; else if (chr != ' ' && chr != '\t' && chr != '\r' && chr != '\n') return chr; } else if (state == BLOCK_COMMENT) { if (chr == BLOCK_COMMENT_CHAR2 && next_char(file) == BLOCK_COMMENT_CHAR1) { get_char(file, pos); state = NO_COMMENT; } else if (chr == EOF) error(UNEXPECTED_EOF_MSG, pos, NULL); } else if (state == LINE_COMMENT) { if (chr == '\n') state = NO_COMMENT; else if (chr == EOF) return EOF; } } } struct s_expr *parse_s_expr (FILE*, struct file_pos*); struct s_expr *parse_list (FILE *file, struct file_pos *pos) { struct s_expr *expr, *rest; int chr; chr = get_significant_char(file, pos); if (chr == LIST_CLOSE_BRACE_CHAR) return NULL; ungetc(chr, file); pos->chr--; expr = alloc_mem(sizeof(*expr)); expr->type = DOTTED_PAIR; expr->u.pair.first = parse_s_expr(file, pos); rest = expr; while (1) { chr = get_significant_char(file, pos); if (chr == LIST_DOT_CHAR) { rest->u.pair.rest = parse_s_expr(file, pos); if (get_significant_char(file, pos) != LIST_CLOSE_BRACE_CHAR) error(BAD_SYNTAX_MSG, pos, NULL); break; } else if (chr == LIST_CLOSE_BRACE_CHAR) { rest->u.pair.rest = NULL; break; } else if (chr == EOF) error(UNEXPECTED_EOF_MSG, pos, NULL); else { ungetc(chr, file); pos->chr--; rest->u.pair.rest = alloc_mem(sizeof(*expr)); rest->u.pair.rest->type = DOTTED_PAIR; rest->u.pair.rest->u.pair.first = parse_s_expr(file, pos); rest = rest->u.pair.rest; } } return expr; } void read_escape_seq (FILE *file, struct file_pos *pos, char *buf) { /* TODO: add support for escape sequences */ } struct s_expr *parse_string (FILE *file, struct file_pos *pos) { char buf[STRING_LENGTH_MAX]; struct s_expr *expr; int chr, i = 0; while (i < STRING_LENGTH_MAX) { chr = get_char(file, pos); if (chr == STRING_ESCAPE_CHAR) read_escape_seq(file, pos, buf); else if (chr == STRING_DELIMITER_CHAR) break; else if (chr == EOF) error(UNEXPECTED_EOF_MSG, pos, NULL); else buf[i++] = chr; } expr = alloc_mem(sizeof(*expr)); expr->type = STRING; expr->u.string.ptr = i ? alloc_mem(i) : NULL; memcpy(expr->u.string.ptr, buf, i); expr->u.string.size = i; return expr; } void read_double (FILE *file, struct file_pos *pos, char *buf) { int chr, i = 0, point = -1; chr = next_char(file); if (chr == '+' || chr == '-') { get_char(file, pos); buf[i++] = chr; } while (i < NUMBER_LENGTH_MAX && isdigit(next_char(file))) buf[i++] = get_char(file, pos); if (i < NUMBER_LENGTH_MAX && next_char(file) == '.') buf[point = i++] = get_char(file, pos); while (i < NUMBER_LENGTH_MAX && isdigit(next_char(file))) buf[i++] = get_char(file, pos); chr = next_char(file); if (i < NUMBER_LENGTH_MAX && (chr == 'e' || chr == 'E') && i > point + 1) { get_char(file, pos); buf[i++] = chr; chr = next_char(file); if (i < NUMBER_LENGTH_MAX && (chr == '+' || chr == '-')) { get_char(file, pos); buf[i++] = chr; } while (i < NUMBER_LENGTH_MAX && isdigit(next_char(file))) buf[i++] = get_char(file, pos); } if (i && i < NUMBER_LENGTH_MAX) buf[i] = 0; else error(BAD_SYNTAX_MSG, pos, NULL); } void read_int (FILE *file, struct file_pos *pos, int base, char *buf) { int chr, i = 0; assert(base == 8 || base == 16); for (; i < NUMBER_LENGTH_MAX; get_char(file, pos)) { chr = next_char(file); if ((base == 16 && isxdigit(chr)) || (chr >= '0' && chr <= '7')) buf[i++] = chr; else break; } if (i && i < NUMBER_LENGTH_MAX) buf[i] = 0; else error(BAD_SYNTAX_MSG, pos, NULL); } struct s_expr *parse_number (FILE *file, struct file_pos *pos) { char buf[NUMBER_LENGTH_MAX + 1]; struct s_expr *expr; int inum; expr = alloc_mem(sizeof(*expr)); expr->type = NUMBER; switch (next_char(file)) { case NUMBER_FORMAT_HEX_CHAR: get_char(file, pos); read_int(file, pos, 16, buf); sscanf(buf, "%x", &inum); expr->u.number = inum; break; case NUMBER_FORMAT_OCT_CHAR: get_char(file, pos); read_int(file, pos, 8, buf); sscanf(buf, "%o", &inum); expr->u.number = inum; break; default: read_double(file, pos, buf); sscanf(buf, "%lf", &expr->u.number); break; } return expr; } struct s_expr *parse_symbol (FILE *file, struct file_pos *pos) { char buf[NUMBER_LENGTH_MAX + 1]; struct s_expr *expr; int chr, chr2, i = 0; for (; i < NUMBER_LENGTH_MAX; get_char(file, pos)) { chr = next_char(file); if (chr == BLOCK_COMMENT_CHAR1) { get_char(file, pos); chr2 = next_char(file); ungetc(chr2, file); pos->chr--; if (chr2 == BLOCK_COMMENT_CHAR2) break; } if (chr >= '!' && chr <= '~' && chr != LINE_COMMENT_CHAR && chr != LIST_OPEN_BRACE_CHAR && chr != LIST_CLOSE_BRACE_CHAR && chr != LIST_DOT_CHAR && chr != STRING_DELIMITER_CHAR && chr != NUMBER_PREFIX_CHAR) buf[i++] = chr; else break; } if (i && i < SYMBOL_LENGTH_MAX) buf[i] = 0; else error(BAD_SYNTAX_MSG, pos, NULL); if(!strcmp(buf, NIL_SYMBOL_STR)) return NULL; if(!strcmp(buf, TRUE_SYMBOL_STR)) return true_(); expr = alloc_mem(sizeof(*expr)); expr->type = SYMBOL; expr->u.symbol = alloc_mem(i + 1); strcpy(expr->u.symbol, buf); return expr; } struct s_expr *parse_s_expr (FILE *file, struct file_pos *pos) { struct s_expr *expr; int chr; chr = get_significant_char(file, pos); switch (chr) { case EOF: return NULL; case LIST_OPEN_BRACE_CHAR: expr = parse_list(file, pos); break; case STRING_DELIMITER_CHAR: expr = parse_string(file, pos); break; case NUMBER_PREFIX_CHAR: expr = parse_number(file, pos); break; default: ungetc(chr, file); pos->chr--; expr = parse_symbol(file, pos); break; } return expr; } struct l_env { char *symbol; struct s_expr *expr; struct l_env *next; }; static int do_trace = 0; char *s_expr_string (struct s_expr*, struct l_env*); void trace_put (char *format, struct s_expr *expr1, struct s_expr *expr2, struct l_env *env) { if (do_trace) { printf("Trace: "); printf(format, s_expr_string(expr1, env), s_expr_string(expr2, env)); puts(""); } } struct l_env *add_symbol (char *symbol, struct s_expr *expr, struct l_env *env, int append) { struct l_env *new_env; new_env = alloc_mem(sizeof(*new_env)); new_env->symbol = symbol, new_env->expr = expr; if (append) env->next = new_env, new_env->next = NULL; else new_env->next = env; return new_env; } struct l_env * add_built_in (int macro, char *symbol, built_in bi, struct l_env *env) { struct s_expr *expr = alloc_mem(sizeof(*expr)); expr->type = macro ? BUILT_IN_MACRO : BUILT_IN_FUNCTION; expr->u.built_in = bi; return add_symbol(symbol, expr, env, 0); } int find_symbol (char *symbol, struct l_env **env) { struct l_env *next = *env; for (; next; *env = next, next = next->next) if (!strcmp(symbol, next->symbol)) { *env = next; return 1; } return 0; } char *str_cat (char *dest, size_t dest_size, char *src) { if (strlen(src) > dest_size - 1 - strlen(dest)) error(STRING_OVERFLOW_MSG, NULL, NULL); return strcat(dest, src); } char *list_string (struct s_expr *list, struct l_env *env) { char buf[S_EXPR_LENGTH_MAX + 1] = { LIST_OPEN_BRACE_CHAR, 0 }; char psep[] = { ' ', LIST_DOT_CHAR, ' ', 0 }; char cbrc[] = { LIST_CLOSE_BRACE_CHAR, 0 }; for (; list && list->type == DOTTED_PAIR; list = list->u.pair.rest) { if (buf[1]) str_cat(buf, S_EXPR_LENGTH_MAX + 1, " "); str_cat(buf, S_EXPR_LENGTH_MAX + 1, s_expr_string(list->u.pair.first, env)); } if (list) str_cat(str_cat(buf, S_EXPR_LENGTH_MAX + 1, psep), S_EXPR_LENGTH_MAX + 1, s_expr_string(list, env)); str_cat(buf, S_EXPR_LENGTH_MAX + 1, cbrc); return strcpy(alloc_mem(strlen(buf) + 1), buf); } char *string_string (char *ptr, size_t size) { char *str = alloc_mem(size + 3); str[0] = str[size + 1] = '"'; memcpy(str + 1, ptr, size); str[size + 2] = 0; return str; } char *number_string (double number) { char *str = alloc_mem(NUMBER_LENGTH_MAX + 2); str[0] = NUMBER_PREFIX_CHAR; sprintf(str + 1, "%g", number); return str; } char *function_string (struct s_expr *expr, int macro, struct l_env *env) { char *str; for (; env; env = env->next) if (env->expr == expr) break; str = alloc_mem((macro ? sizeof(MACRO_STR_FORMAT) : sizeof(FUNCTION_STR_FORMAT)) + (env ? strlen(env->symbol) : 0) - 1); sprintf(str, macro ? MACRO_STR_FORMAT : FUNCTION_STR_FORMAT, env ? env->symbol : ""); return str; } char *s_expr_string (struct s_expr *expr, struct l_env *env) { if (!expr) return NIL_SYMBOL_STR; switch (expr->type) { case DOTTED_PAIR: return list_string(expr, env); case STRING: return string_string(expr->u.string.ptr, expr->u.string.size); case SYMBOL: return expr->u.symbol; case NUMBER: return number_string(expr->u.number); case FUNCTION: case BUILT_IN_FUNCTION: return function_string(expr, 0, env); case MACRO: case BUILT_IN_MACRO: return function_string(expr, 1, env); default: assert(0); return NULL; } } int proper_listp (struct s_expr *expr) { while (expr && expr->type == DOTTED_PAIR) expr = expr->u.pair.rest; return expr == NULL; } struct s_expr *search_symbol(struct s_expr *list, char *symbol) { for (; list && list->type == DOTTED_PAIR; list = list->u.pair.rest) { assert(list->u.pair.first->type == SYMBOL); if (!strcmp(list->u.pair.first->u.symbol, symbol)) return list; } return NULL; } void check_fargs (struct s_expr *fargs, struct l_env *env, struct file_pos *pos) { struct s_expr *rest = fargs; if (rest && rest->type == DOTTED_PAIR && !rest->u.pair.first && rest->u.pair.rest->type == SYMBOL) return; for (; rest && rest->type == DOTTED_PAIR; rest = rest->u.pair.rest) if (!rest->u.pair.first || rest->u.pair.first->type != SYMBOL || search_symbol(fargs, rest->u.pair.first->u.symbol) != rest) error(BAD_FORMAL_ARGS_MSG, pos, s_expr_string(fargs, env)); if (rest && (rest->type != SYMBOL || search_symbol(fargs, rest->u.symbol))) error(BAD_FORMAL_ARGS_MSG, pos, s_expr_string(fargs, env)); } void check_aargs (struct s_expr *args, int count, int va, struct l_env *env, struct file_pos *pos) { struct s_expr *rest = args; for (; count && rest && rest->type == DOTTED_PAIR; count--) rest = rest->u.pair.rest; if (count || (!va && rest) || !proper_listp(rest)) error(BAD_ACTUAL_ARGS_MSG, pos, s_expr_string(args, env)); } struct s_expr *eval_list (struct s_expr*, struct l_env*, struct file_pos*); struct s_expr *eval_s_expr (struct s_expr*, struct l_env*, struct file_pos*); #define ARG1(args) args->u.pair.first #define ARG2(args) args->u.pair.rest->u.pair.first #define ARG3(args) args->u.pair.rest->u.pair.rest->u.pair.first struct s_expr *trace (struct s_expr *args, struct l_env *env, struct file_pos *pos) { struct s_expr *expr; do_trace = 1; expr = eval_list(args, env, pos); do_trace = 0; return expr; } struct s_expr *quote (struct s_expr *args, struct l_env *env, struct file_pos *pos) { check_aargs(args, 1, 0, env, pos); return ARG1(args); } struct s_expr *car (struct s_expr *args, struct l_env *env, struct file_pos *pos) { check_aargs(args, 1, 0, env, pos); if (ARG1(args) && ARG1(args)->type != DOTTED_PAIR) error(NON_LIST_MSG, pos, s_expr_string(ARG1(args), env)); return ARG1(args) ? ARG1(args)->u.pair.first : NULL; } struct s_expr *cdr (struct s_expr *args, struct l_env *env, struct file_pos *pos) { check_aargs(args, 1, 0, env, pos); if (ARG1(args) && ARG1(args)->type != DOTTED_PAIR) error(NON_LIST_MSG, pos, s_expr_string(ARG1(args), env)); return ARG1(args) ? ARG1(args)->u.pair.rest : NULL; } struct s_expr *cons (struct s_expr *args, struct l_env *env, struct file_pos *pos) { struct s_expr *expr; check_aargs(args, 2, 0, env, pos); expr = alloc_mem(sizeof(*expr)); expr->type = DOTTED_PAIR; expr->u.pair.first = ARG1(args); expr->u.pair.rest = ARG2(args); return expr; } struct s_expr *if_ (struct s_expr *args, struct l_env *env, struct file_pos *pos) { check_aargs(args, 3, 0, env, pos); return eval_s_expr(ARG1(args), env, pos) ? eval_s_expr(ARG2(args), env, pos) : eval_s_expr(ARG3(args), env, pos); } struct s_expr *function (struct s_expr *args, struct l_env *env, struct file_pos *pos, int macro) { struct s_expr *expr; check_aargs(args, 1, 1, env, pos); check_fargs(ARG1(args), env, pos); expr = alloc_mem(sizeof(*expr)); expr->type = macro ? MACRO : FUNCTION; expr->u.function.expr = args; expr->u.function.env = env; return expr; } struct s_expr *lambda (struct s_expr *args, struct l_env *env, struct file_pos *pos) { return function(args, env, pos, 0); } struct s_expr *macro (struct s_expr *args, struct l_env *env, struct file_pos *pos) { return function(args, env, pos, 1); } struct s_expr *setq (struct s_expr *args, struct l_env *env, struct file_pos *pos) { struct s_expr *rest = args, *expr = NULL; struct l_env *senv; while (rest && rest->type == DOTTED_PAIR) { if (ARG1(rest) && ARG1(rest)->type == SYMBOL && rest->u.pair.rest && rest->u.pair.rest->type == DOTTED_PAIR) { expr = eval_s_expr(ARG2(rest), env, pos), senv = env; if (find_symbol(ARG1(rest)->u.symbol, &senv)) { trace_put("%s => %s [assign]", expr, ARG1(rest), env); senv->expr = expr; } else { trace_put("%s => %s [global]", expr, ARG1(rest), env); add_symbol(ARG1(rest)->u.symbol, expr, senv, 1); } } else error(BAD_ACTUAL_ARGS_MSG, pos, s_expr_string(args, env)); rest = rest->u.pair.rest->u.pair.rest; } if (rest) error(BAD_ACTUAL_ARGS_MSG, pos, s_expr_string(args, env)); return expr; } struct s_expr *plus (struct s_expr *args, struct l_env *env, struct file_pos *pos) { struct s_expr *rest = args; double sum = 0; while (rest && rest->type == DOTTED_PAIR && ARG1(rest)->type == NUMBER) sum += ARG1(rest)->u.number, rest = rest->u.pair.rest; if (rest) error(BAD_ACTUAL_ARGS_MSG, pos, s_expr_string(args, env)); rest = alloc_mem(sizeof(*rest)); rest->type = NUMBER; rest->u.number = sum; return rest; } struct s_expr *greater (struct s_expr *args, struct l_env *env, struct file_pos *pos) { struct s_expr *rest = args, *num; double prev = DBL_MAX; while (rest && rest->type == DOTTED_PAIR) { num = eval_s_expr(ARG1(rest), env, pos); if (!num || num->type != NUMBER) error(BAD_ACTUAL_ARGS_MSG, pos, s_expr_string(args, env)); if (prev - num->u.number < DBL_EPSILON) return NULL; prev = num->u.number, rest = rest->u.pair.rest; } if (rest) error(BAD_ACTUAL_ARGS_MSG, pos, s_expr_string(args, env)); return true_(); } struct l_env *create_env () { struct l_env *env = NULL; env = add_built_in(1, TRACE_SYMBOL_STR, trace, env); env = add_built_in(1, QUOTE_SYMBOL_STR, quote, env); env = add_built_in(0, CAR_SYMBOL_STR, car, env); env = add_built_in(0, CDR_SYMBOL_STR, cdr, env); env = add_built_in(0, CONS_SYMBOL_STR, cons, env); env = add_built_in(1, IF_SYMBOL_STR, if_, env); env = add_built_in(1, LAMBDA_SYMBOL_STR, lambda, env); env = add_built_in(1, MACRO_SYMBOL_STR, macro, env); env = add_built_in(1, SETQ_SYMBOL_STR, setq, env); env = add_built_in(0, PLUS_SYMBOL_STR, plus, env); env = add_built_in(1, GREATER_SYMBOL_STR, greater, env); return env; } struct s_expr *map_eval (struct s_expr *list, struct l_env *env, struct file_pos *pos) { struct s_expr *expr = NULL, *rest; while (list) { if (list->type != DOTTED_PAIR) error(NON_LIST_MSG, pos, s_expr_string(list, env)); if (expr) { rest->u.pair.rest = alloc_mem(sizeof(*expr)); rest = rest->u.pair.rest; } else expr = rest = alloc_mem(sizeof(*expr)); rest->type = DOTTED_PAIR; rest->u.pair.first = eval_s_expr(list->u.pair.first, env, pos); list = list->u.pair.rest; } if (expr) rest->u.pair.rest = NULL; return expr; } struct l_env *apply_args (struct s_expr *fargs, struct s_expr *aargs, struct l_env *env, struct file_pos *pos) { struct s_expr *rest = aargs; if (!fargs || fargs->u.pair.first) while (fargs && fargs->type == DOTTED_PAIR) { if (!rest || rest->type != DOTTED_PAIR) error(BAD_ACTUAL_ARGS_MSG, pos, s_expr_string(aargs, env)); assert(fargs->u.pair.first->type == SYMBOL); trace_put("%s => %s [local]", rest->u.pair.first, fargs->u.pair.first, env); env = add_symbol(fargs->u.pair.first->u.symbol, rest->u.pair.first, env, 0); fargs = fargs->u.pair.rest, rest = rest->u.pair.rest; } else fargs = fargs->u.pair.rest; if (fargs) { assert(fargs->type == SYMBOL); if (rest && !proper_listp(rest)) error(BAD_ACTUAL_ARGS_MSG, pos, s_expr_string(aargs, env)); trace_put("%s => %s [local]", rest, fargs, env); env = add_symbol(fargs->u.symbol, rest, env, 0); } else if (rest) error(BAD_ACTUAL_ARGS_MSG, pos, s_expr_string(aargs, env)); return env; } struct s_expr *eval_list (struct s_expr *list, struct l_env *env, struct file_pos *pos) { struct s_expr *expr = NULL, *rest = list; for (; rest && rest->type == DOTTED_PAIR; rest = rest->u.pair.rest) expr = eval_s_expr(rest->u.pair.first, env, pos); if (rest) error(NON_LIST_MSG, pos, s_expr_string(list, env)); return expr; } struct s_expr *eval_s_expr (struct s_expr *expr, struct l_env *env, struct file_pos *pos) { struct s_expr *first, *in = expr; struct l_env *benv; trace_put("%s -> ...", in, NULL, env); if (expr) if (expr->type == SYMBOL) if (find_symbol(expr->u.symbol, &env)) expr = env->expr; else error(UNBOUND_SYMBOL_MSG, pos, expr->u.symbol); else if (expr->type == DOTTED_PAIR) { first = eval_s_expr(expr->u.pair.first, env, pos); if (!first || first->type == DOTTED_PAIR || first->type == SYMBOL || first->type == STRING || first->type == NUMBER) error(NON_FUNC_MACRO_MSG, pos, s_expr_string(first, env)); expr = first->type == FUNCTION || first->type == BUILT_IN_FUNCTION ? map_eval(expr->u.pair.rest, env, pos) : expr->u.pair.rest; if (first->type == FUNCTION || first->type == MACRO) { assert(first->u.function.expr->type == DOTTED_PAIR); benv = apply_args(first->u.function.expr->u.pair.first, expr, first->u.function.env, pos); expr = eval_list(first->u.function.expr->u.pair.rest, benv, pos); if (first->type == MACRO) { trace_put("%s ~> %s", in, expr, env); expr = eval_s_expr(expr, env, pos); } } else expr = first->u.built_in(expr, env, pos); } trace_put("%s -> %s", in, expr, env); return expr; } struct s_expr *eval_file (char *filename, struct l_env *env) { struct file_pos pos, prev_pos; struct s_expr *expr; FILE *file; int chr; file = fopen(filename, "r"); if (!file) { printf("Failed to open file '%s'\n", filename); exit(1); } pos.filename = filename, pos.line = pos.chr = 1; expr = NULL; while (1) { chr = get_significant_char(file, &pos); if (chr == EOF) break; ungetc(chr, file); pos.chr--, prev_pos = pos; expr = eval_s_expr(parse_s_expr(file, &pos), env, &prev_pos); } fclose(file); return expr; } int main (int argc, char *argv[]) { struct l_env *env; if (argc != 2) { puts("Usage: int source"); exit(1); } env = create_env(); puts(s_expr_string(eval_file(argv[1], env), env)); return 0; } 

 ;| Formal argument list notation: ([{arg1 [arg2 [arg3 ...]] | _} [. args]]) Number notation: ${double | ooctal | hhex} ; $4 $-2.2e3 $o376 $h7EF Built-in symbols: _ ; nil Built-in functions: @ (list) ; car % (list) ; cdr ^ (first rest) ; cons + (_ . nums) Built-in macros: trace (_ . body) ' (expr) ? (cond texpr fexpr) ; if with mandatory fexpr ! (args . body) ; lambda # (args . body) ; creates anonymous macro > (_ . nums) |; (= @% (! (list) (@ (% list)))) ; cadr (= %% (! (list) (% (% list)))) ; cddr (= ^^ (! (_ . elts) elts)) ; list (= ## (# (name fargs . body) ; defmacro (^^ = name (^ # (^ fargs body))))) (## !! (name fargs . body) ; defun (^^ = name (^ ! (^ fargs body)))) (!! map (func list) (? list (^ (func (@ list)) (map func (% list))) _)) (!! pairs1 (list) ; (abcd) -> ((ab) (bc) (cd)) (? (% list) (^ (^^ (@ list) (@% list)) (pairs1 (% list))) _)) (!! pairs2 (list) ; (abcd) -> ((ab) (cd)) (? list (^ (^^ (@ list) (@% list)) (pairs2 (%% list))) _)) (## : (name value . body) ; simplified let (^^ (^ ! (^ (^^ name) body)) value)) (## :: (vars . body) ; let without redundant braces (= vars (pairs2 vars)) (^ (^ ! (^ (map @ vars) body)) (map @% vars))) (!! reverse (list) (: reverse+ _ (!! reverse+ (list rlist) (? list (reverse+ (% list) (^ (@ list) rlist)) rlist)) (reverse+ list _))) (!! fold (list func last) ; (fold (' (ab)) fl) <=> (fa (fbl)) (? list (func (@ list) (fold (% list) func last)) last)) (= t (' t)) ; true constant (!! ~ (bool) (? bool _ t)) ; not (## & (_ . bools) ; and (: and (! (bool1 bool2) (^^ ? bool1 (^^ ? bool2 t _) _)) (fold bools and t))) (## | (_ . bools) ; or (: or (! (bool1 bool2) (^^ ? bool1 t (^^ ? bool2 t _))) (fold bools or _))) (: defcmp (! (cmp) (# (_ . nums) (: cmp+ (! (pair bool) (^^ & (cmp (@ pair) (@% pair)) bool)) (fold (pairs1 nums) cmp+ t)))) (= == (defcmp (! (num1 num2) (^^ & (^^ ~ (^^ > num1 num2)) (^^ ~ (^^ > num2 num1)))))) (= >= (defcmp (! (num1 num2) (^^ ~ (^^ > num2 num1)))))) (## < (_ . nums) (^ > (reverse nums))) (## <= (_ . nums) (^ >= (reverse nums)))