| @@ -85,9 +85,6 @@ condition is false." | |||||
| ,(rec (rest clauses)))))) | ,(rec (rest clauses)))))) | ||||
| (rec clauses)) | (rec clauses)) | ||||
| (define-syntax (define-special name-and-args . body) | |||||
| `(define ,(first name-and-args) (special-lambda ,(rest name-and-args) @body))) | |||||
| (define-syntax (construct-list . body) | (define-syntax (construct-list . body) | ||||
| :doc " | :doc " | ||||
| {{{example_start}}} | {{{example_start}}} | ||||
| @@ -471,7 +468,6 @@ added to a list, which in the end is returned." | |||||
| ;; (vector-ref v2 0)))) | ;; (vector-ref v2 0)))) | ||||
| ;; (unless (bound? generic-+-map) | ;; (unless (bound? generic-+-map) | ||||
| ;; (set! generic-+-map (create-hash-map))) | ;; (set! generic-+-map (create-hash-map))) | ||||
| ;; (hm/set! generic-+-map '(:vector :vector) (lambda (v1 v2) | ;; (hm/set! generic-+-map '(:vector :vector) (lambda (v1 v2) | ||||
| @@ -18,8 +18,6 @@ | |||||
| (define-syntax (case var . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error :syntax-error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if (member? ,var ',(first (first clauses))) (begin (unquote-splicing (rest (first clauses)))) ,(rec (rest clauses)))))) (rec clauses)) | (define-syntax (case var . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error :syntax-error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if (member? ,var ',(first (first clauses))) (begin (unquote-splicing (rest (first clauses)))) ,(rec (rest clauses)))))) (rec clauses)) | ||||
| (define-syntax (define-special name-and-args . body) `(define ,(first name-and-args) (special-lambda ,(rest name-and-args) (unquote-splicing body)))) | |||||
| (define-syntax (construct-list . body) :doc "\n{{{example_start}}}\n(construct-list\n i <- '(1 2 3 4 5)\n yield (* i i))\n{{{example_end}}}\n\n(construct-list\n i <- '(1 2 3 4)\n j <- '(A B)\n yield (pair i j))\n\n(construct-list\n i <- '(1 2 3 4 5 6 7 8)\n if (= 0 (% i 2))\n yield i)\n" (define (append-map f ll) (unless (= ll ()) (define val (f (first ll))) (if (= (first val) ()) (append-map f (rest ll)) (extend val (append-map f (rest ll)))))) (define (rec body) (cond ((= () body) ()) ((= () (rest body)) (first body)) ((= (first (rest body)) '<-) `(,append-map (lambda (,(first body)) (list ,(rec (rest (rest (rest body)))))) ,(first (rest (rest body))))) ((= (first body) 'if) `(when ,(first (rest body)) ,(rec (rest (rest body))))) ((= (first (rest body)) 'yield) (first (rest body))) (else (error :syntax-error "Not a do-able expression")))) (rec body)) | (define-syntax (construct-list . body) :doc "\n{{{example_start}}}\n(construct-list\n i <- '(1 2 3 4 5)\n yield (* i i))\n{{{example_end}}}\n\n(construct-list\n i <- '(1 2 3 4)\n j <- '(A B)\n yield (pair i j))\n\n(construct-list\n i <- '(1 2 3 4 5 6 7 8)\n if (= 0 (% i 2))\n yield i)\n" (define (append-map f ll) (unless (= ll ()) (define val (f (first ll))) (if (= (first val) ()) (append-map f (rest ll)) (extend val (append-map f (rest ll)))))) (define (rec body) (cond ((= () body) ()) ((= () (rest body)) (first body)) ((= (first (rest body)) '<-) `(,append-map (lambda (,(first body)) (list ,(rec (rest (rest (rest body)))))) ,(first (rest (rest body))))) ((= (first body) 'if) `(when ,(first (rest body)) ,(rec (rest (rest body))))) ((= (first (rest body)) 'yield) (first (rest body))) (else (error :syntax-error "Not a do-able expression")))) (rec body)) | ||||
| (define-syntax (define-typed args . body) (define (get-arg-names args) (when args (pair (first args) (get-arg-names (rest (rest args)))))) (let ((name (first args)) (lambda-list (rest args)) (arg-names (get-arg-names (rest args)))) `(define (,name (unquote-splicing arg-names)) (assert-types= (unquote-splicing lambda-list)) (unquote-splicing body)))) | (define-syntax (define-typed args . body) (define (get-arg-names args) (when args (pair (first args) (get-arg-names (rest (rest args)))))) (let ((name (first args)) (lambda-list (rest args)) (arg-names (get-arg-names (rest args)))) `(define (,name (unquote-splicing arg-names)) (assert-types= (unquote-splicing lambda-list)) (unquote-splicing body)))) | ||||
| @@ -5,6 +5,7 @@ pushd $SCRIPTPATH > /dev/null | |||||
| # _DEBUG | # _DEBUG | ||||
| # time g++ -fpermissive src/main.cpp -g -o ./bin/slime --std=c++17 || exit 1 | # time g++ -fpermissive src/main.cpp -g -o ./bin/slime --std=c++17 || exit 1 | ||||
| time clang++ -D_DEBUG -D_PROFILING -D_DONT_BREAK_ON_ERRORS src/main.cpp -g -o ./bin/slime --std=c++17 || exit 1 | time clang++ -D_DEBUG -D_PROFILING -D_DONT_BREAK_ON_ERRORS src/main.cpp -g -o ./bin/slime --std=c++17 || exit 1 | ||||
| # time clang++ -O3 -D_DONT_BREAK_ON_ERRORS src/main.cpp -g -o ./bin/slime --std=c++17 || exit 1 | |||||
| echo "" | echo "" | ||||
| pushd ./bin > /dev/null | pushd ./bin > /dev/null | ||||
| @@ -779,31 +779,27 @@ proc load_built_ins_into_environment() -> void { | |||||
| fun->value.function.body = maybe_wrap_body_in_begin(body); | fun->value.function.body = maybe_wrap_body_in_begin(body); | ||||
| return fun; | return fun; | ||||
| }; | }; | ||||
| define_special((special-lambda args . body), "TODO") { | |||||
| fetch(args, body); | |||||
| Lisp_Object* fun; | |||||
| try fun = Memory::create_lisp_object(); | |||||
| Memory::set_type(fun, Lisp_Object_Type::Function); | |||||
| fun->value.function.type = Function_Type::Special_Lambda; | |||||
| in_caller_env { | |||||
| fun->value.function.parent_environment = get_current_environment(); | |||||
| } | |||||
| try create_arguments_from_lambda_list_and_inject(args, fun); | |||||
| fun->value.function.body = maybe_wrap_body_in_begin(body); | |||||
| return fun; | |||||
| }; | |||||
| // define_special((special-lambda args . body), "TODO") { | |||||
| // fetch(args, body); | |||||
| // Lisp_Object* fun; | |||||
| // try fun = Memory::create_lisp_object(); | |||||
| // Memory::set_type(fun, Lisp_Object_Type::Function); | |||||
| // fun->value.function.type = Function_Type::Special_Lambda; | |||||
| // in_caller_env { | |||||
| // fun->value.function.parent_environment = get_current_environment(); | |||||
| // } | |||||
| // try create_arguments_from_lambda_list_and_inject(args, fun); | |||||
| // fun->value.function.body = maybe_wrap_body_in_begin(body); | |||||
| // return fun; | |||||
| // }; | |||||
| define((apply fun args), "TODO") { | define((apply fun args), "TODO") { | ||||
| fetch(fun, args); | fetch(fun, args); | ||||
| Lisp_Object* result; | Lisp_Object* result; | ||||
| // try assert_type(args, Lisp_Object_Type::Pair); | |||||
| // HACK(Felix): this is probably a really nasty hack: | |||||
| fluid_let (fun->value.function.type, Function_Type::Special_Lambda) { | |||||
| try result = apply_arguments_to_function(args, fun); | |||||
| } | |||||
| try result = apply_arguments_to_function(args, fun, /*eval_args=*/false); | |||||
| return result; | return result; | ||||
| }; | }; | ||||
| @@ -907,8 +903,8 @@ proc load_built_ins_into_environment() -> void { | |||||
| Function* fun = &n->value.function; | Function* fun = &n->value.function; | ||||
| if (fun->type == Function_Type::Lambda) | if (fun->type == Function_Type::Lambda) | ||||
| return Memory::get_or_create_lisp_object_keyword("lambda"); | return Memory::get_or_create_lisp_object_keyword("lambda"); | ||||
| else if (fun->type == Function_Type::Special_Lambda) | |||||
| return Memory::get_or_create_lisp_object_keyword("special-lambda"); | |||||
| // else if (fun->type == Function_Type::Special_Lambda) | |||||
| // return Memory::get_or_create_lisp_object_keyword("special-lambda"); | |||||
| else if (fun->type == Function_Type::Macro) | else if (fun->type == Function_Type::Macro) | ||||
| return Memory::get_or_create_lisp_object_keyword("macro"); | return Memory::get_or_create_lisp_object_keyword("macro"); | ||||
| else return Memory::get_or_create_lisp_object_keyword("unknown"); | else return Memory::get_or_create_lisp_object_keyword("unknown"); | ||||
| @@ -1,6 +1,7 @@ | |||||
| proc create_extended_environment_for_function_application( | proc create_extended_environment_for_function_application( | ||||
| Lisp_Object* unevaluated_arguments, | Lisp_Object* unevaluated_arguments, | ||||
| Lisp_Object* function) -> Environment* | |||||
| Lisp_Object* function, | |||||
| bool should_evaluate) -> Environment* | |||||
| { | { | ||||
| profile_this; | profile_this; | ||||
| bool is_c_function = Memory::get_type(function) == Lisp_Object_Type::CFunction; | bool is_c_function = Memory::get_type(function) == Lisp_Object_Type::CFunction; | ||||
| @@ -15,17 +16,12 @@ proc create_extended_environment_for_function_application( | |||||
| if (is_c_function) { | if (is_c_function) { | ||||
| new_env = Memory::create_child_environment(get_root_environment()); | new_env = Memory::create_child_environment(get_root_environment()); | ||||
| arg_spec = &function->value.cFunction->args; | arg_spec = &function->value.cFunction->args; | ||||
| // if it is not a special form, evaluate the arguments | |||||
| if (!function->value.cFunction->is_special_form) { | |||||
| try arguments = eval_arguments(arguments); | |||||
| } | |||||
| } else { | } else { | ||||
| new_env = Memory::create_child_environment(function->value.function.parent_environment); | new_env = Memory::create_child_environment(function->value.function.parent_environment); | ||||
| arg_spec = &function->value.function.args; | arg_spec = &function->value.function.args; | ||||
| // if it is a lambda | |||||
| if (function->value.function.type == Function_Type::Lambda) { | |||||
| try arguments = eval_arguments(arguments); | |||||
| } | |||||
| } | |||||
| if (should_evaluate) { | |||||
| try arguments = eval_arguments(arguments); | |||||
| } | } | ||||
| // NOTE(Felix): Even though we will return the environment at the | // NOTE(Felix): Even though we will return the environment at the | ||||
| @@ -230,12 +226,12 @@ proc create_extended_environment_for_function_application( | |||||
| return new_env; | return new_env; | ||||
| } | } | ||||
| proc apply_arguments_to_function(Lisp_Object* arguments, Lisp_Object* function) -> Lisp_Object* { | |||||
| proc apply_arguments_to_function(Lisp_Object* arguments, Lisp_Object* function, bool should_evaluate_args) -> Lisp_Object* { | |||||
| profile_this; | profile_this; | ||||
| Environment* new_env; | Environment* new_env; | ||||
| Lisp_Object* result; | Lisp_Object* result; | ||||
| try new_env = create_extended_environment_for_function_application(arguments, function); | |||||
| try new_env = create_extended_environment_for_function_application(arguments, function, should_evaluate_args); | |||||
| push_environment(new_env); | push_environment(new_env); | ||||
| defer { | defer { | ||||
| pop_environment(); | pop_environment(); | ||||
| @@ -435,7 +431,10 @@ proc eval_expr(Lisp_Object* node) -> Lisp_Object* { | |||||
| // check for c function | // check for c function | ||||
| if (Memory::get_type(lispOperator) == Lisp_Object_Type::CFunction) { | if (Memory::get_type(lispOperator) == Lisp_Object_Type::CFunction) { | ||||
| Lisp_Object* result; | Lisp_Object* result; | ||||
| try result = apply_arguments_to_function(arguments, lispOperator); | |||||
| try result = apply_arguments_to_function( | |||||
| arguments, | |||||
| lispOperator, | |||||
| !lispOperator->value.cFunction->is_special_form); | |||||
| return result; | return result; | ||||
| } | } | ||||
| @@ -446,7 +445,10 @@ proc eval_expr(Lisp_Object* node) -> Lisp_Object* { | |||||
| // we do not need. | // we do not need. | ||||
| Lisp_Object* result; | Lisp_Object* result; | ||||
| try result = apply_arguments_to_function(arguments, lispOperator); | |||||
| try result = apply_arguments_to_function( | |||||
| arguments, | |||||
| lispOperator, | |||||
| lispOperator->value.function.type == Function_Type::Lambda); | |||||
| // NOTE(Felix): The parser does not understnad (import ..) | // NOTE(Felix): The parser does not understnad (import ..) | ||||
| // so it cannot expand imported macros at read time | // so it cannot expand imported macros at read time | ||||
| @@ -313,8 +313,8 @@ proc print(Lisp_Object* node, bool print_repr = false, FILE* file = stdout) -> v | |||||
| } | } | ||||
| if (node->value.function.type == Function_Type::Lambda) | if (node->value.function.type == Function_Type::Lambda) | ||||
| fputs("[lambda]", file); | fputs("[lambda]", file); | ||||
| else if (node->value.function.type == Function_Type::Special_Lambda) | |||||
| fputs("[special-lambda]", file); | |||||
| // else if (node->value.function.type == Function_Type::Special_Lambda) | |||||
| // fputs("[special-lambda]", file); | |||||
| else if (node->value.function.type == Function_Type::Macro) | else if (node->value.function.type == Function_Type::Macro) | ||||
| fputs("[macro]", file); | fputs("[macro]", file); | ||||
| else | else | ||||
| @@ -52,7 +52,7 @@ enum class Lisp_Object_Flags : u64 | |||||
| enum struct Function_Type { | enum struct Function_Type { | ||||
| Lambda, | Lambda, | ||||
| Special_Lambda, | |||||
| // Special_Lambda, | |||||
| Macro | Macro | ||||
| }; | }; | ||||