├── LICENSE ├── README.md └── src ├── lisp.c ├── lisp.h ├── list.c ├── list.h ├── operators.c ├── operators.h ├── parser.c ├── primitives.c ├── primitives.h ├── printer.c └── stdlib.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2013 Johan Fjeldtvedt 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | lispc 2 | ===== 3 | 4 | A simple Lisp interpreter written in C. It implements the most basic Lisp special forms (called operators here) as well as a small number of primitive procedures. It is lexically scoped and supports closures. 5 | 6 | ## Building 7 | 8 | lispc should build out of the box on any system. Using gcc, simply do 9 | 10 | > `gcc *.c -o lisp -std=c99` 11 | 12 | Running the resulting executable will start the lispc interpreter. It does not parse files at the moment, and the REPL is very simple. 13 | 14 | ## Language 15 | 16 | lispc is a minimalistic Lisp language. Expressions in lispc are either symbols, procedures, numbers or lists. Symbols are used as names in variable bindings, or can be used as identifiers for other purposes. A symbol evaluates to the value it is bound to. Numbers and procedures evaluate to themselves. List evaluation follows two basic rules: If the first element is a symbol and the symbol denotes one of the *operators*, evaluation rules for the particular operator is followed. If the first element does not denote one of the operators, the list expression is a function call. Every element in the list is evaluated, and the first element, if resulting in a procedure, is called with the rest of the elements as arguments. 17 | 18 | Some examples: 19 | 20 | Numbers evaluate to themselves: 21 | 22 | LISP> 1234 23 | => 1234 24 | 25 | `def` is an operator, so the following list expression will be an operator call: 26 | 27 | LISP> (def k 2) 28 | => K 29 | 30 | The symbol `k` will after that call refer to the value 2: 31 | 32 | LISP> k 33 | => 2 34 | 35 | A list where the first element is not an operator is a function call: 36 | 37 | LISP> (+ 1 (* 1 2) 3) 38 | => 6 39 | 40 | ### Operators 41 | 42 | #### `\` (lambda) 43 | 44 | `(\ (a1 a2 ...) exp)` constructs a function whose formal parameters are `a1`, `a2` and so on, and whose expression is `exp`. 45 | 46 | Example: 47 | 48 | (\ (x y z) (+ x y z)) ; a function which takes three arguments and sums them 49 | ((\ (x y z) (+ x y z)) 1 2 3) ; create the described procedure and call it with arguments 1, 2 and 3 50 | 51 | #### `def` 52 | 53 | `(def a b)` introduces a new *variable binding* where the symbol `a` is bound tothe value `b`. 54 | 55 | Example: 56 | 57 | (def a 5) ; define a to be 5 58 | (def square (\ (x) (* x x))) ; set square to be the function which squares its argument 59 | 60 | #### `if` 61 | 62 | `(if test true-exp false-exp)` evaluates `test`. If the result is non-`NIL`, `true-exp` is evaluated. Otherwise, `false-exp` is evaluated. 63 | 64 | Example: 65 | 66 | (if (= x 2) (+ x 1) 2) ; evaluates (+ x 1) if x is equal to 2, or evaluates 2 if not 67 | 68 | #### `'` (quote) 69 | 70 | `(' exp)` simply evaluates to `exp`. The parser will convert expressions of the form `'x` to `(' x)`. 71 | 72 | Example: 73 | 74 | LISP> (' k) 75 | => K 76 | LISP> 'k 77 | => K 78 | 79 | #### `set!` 80 | 81 | `(set! a b)` changes the value what `a` refers to, to the value `b`. 82 | 83 | #### `let` 84 | 85 | `(let ((a1 b1) (a2 b2) ...) exp)` introduces *local bindings* of the symbol `a1` to the value `b1`, the symbol `a2` to the value `b2`, and so on. With these bindings, the `exp` expression is evaluated. The bindings only exist during the evaluation of `exp`. Already existant bindings outside the `let` scope will be shadowed by these bindings. 86 | 87 | Example: 88 | 89 | (let ((x 2) (y 3)) 90 | (+ x y)) ; x and y are only bound in this expression 91 | 92 | #### `do` or `:` 93 | 94 | `(do exp1 exp2 ...)` evaluates the expressions `exp1`, `exp2`, ... in order, and uses the last evaluated value as its value. 95 | 96 | Example: 97 | 98 | (do (print 'hi) 99 | (print 'there) 100 | 1234) 101 | 102 | This will print "HI THERE" on the screen, and the expression will evaluate to 1234. 103 | 104 | ### Primitives 105 | 106 | ### Generic functions 107 | 108 | The standard library defines the functions `new-generic` and `implement` for using generic functions. 109 | 110 | `(new-generic name)` creates a new generic function called `name` and returns a procedure which can call it. 111 | 112 | `(implement name fn type)` defines a specific implementation of the generic function. `name` is the symbol of the generic function, `fn` is the implementing procedure, and `type` is a list or a symbol denoting the argument types the implementation handles. If `type` is a single symbol, the implementation is assumed to take a variable number of arguments, and every argument has to match this type. If `type` is a list, its items denote the argument types in order. 113 | 114 | #### Example 115 | 116 | The function + might be useful to overload for certain types. The standard library implements + for integers as follows: 117 | 118 | (def + (new-generic '+)) 119 | (implement '+ _+ 'integer) 120 | 121 | Here, `_+` denotes the built in primitive procedure for adding integers. The symbolic type argument makes this implementation accept a variable number of arguments, all of integer type. 122 | 123 | To add a new implementation, for example for a type `matrix`, we can do 124 | 125 | (implement '+ add-matrix '(matrix matrix)) 126 | 127 | Here, the type argument is a list of two elements, meaning that this implementation will take two arguments, both of type `matrix`. The function `add-matrix` must be a function taking at least two such arguments. 128 | -------------------------------------------------------------------------------- /src/lisp.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "lisp.h" 5 | #include "list.h" 6 | #include "operators.h" 7 | 8 | const char* type_names[] = {"INTEGER", "SYMBOL", "LIST", "PROCEDURE", "BINDING", "ERROR", "OPERATOR"}; 9 | 10 | int compare_values(Value* a, Value* b) 11 | { 12 | // First of all, two values are identical if they point to the same data 13 | if (a->data == b->data) return 1; 14 | 15 | // Secondly, types have to match 16 | if (a->type == b->type) 17 | switch (a->type) { 18 | 19 | case TYPE_INTEGER: 20 | return *(int*)a->data == *(int*)b->data; 21 | case TYPE_SYMBOL: 22 | return (strcmp((char*)a->data, (char*)b->data) == 0); 23 | case TYPE_BINDING: 24 | // Bindings are equal when bound values are equal 25 | return !strcmp(((Binding*)a->data)->symbol, ((Binding*)b->data)->symbol); 26 | case TYPE_PROCEDURE: 27 | // Procedures are generally not equal 28 | return 0; 29 | case TYPE_LIST: 30 | { 31 | List* lst_a = (List*)a->data; 32 | List* lst_b = (List*)b->data; 33 | if (lst_a->length != lst_b->length) return 0; 34 | Node* node_a = lst_a->first; 35 | Node* node_b = lst_b->first; 36 | for (int i = 0; i < lst_a->length; i++) { 37 | if (!compare_values(node_a->value, node_b->value)) 38 | return 0; 39 | node_a = node_a->next; 40 | node_b = node_b->next; 41 | } 42 | return 1; 43 | } 44 | } 45 | return 0; 46 | } 47 | 48 | Value* environment_lookup(List* environment, char* name) 49 | { 50 | Node* current = environment->first; 51 | Binding* current_binding; 52 | for (int i = 0; i < environment->length; i++) { 53 | current_binding = (Binding*)current->value->data; 54 | if (!strcmp(current_binding->symbol, name)) 55 | return current_binding->value; 56 | current = current->next; 57 | } 58 | char* errorstring = (char*)malloc(sizeof(char) * (strlen(name) + 30)); 59 | strcpy(errorstring, "unbound variable "); 60 | strcpy(errorstring + strlen(errorstring), name); 61 | return alloc_value(TYPE_ERROR, errorstring); 62 | } 63 | 64 | int* allocate_integer(int value) 65 | { 66 | int* integer = (int*)malloc(sizeof(int)); 67 | *integer = value; 68 | return integer; 69 | } 70 | 71 | Value* alloc_value(int type, void* data) 72 | { 73 | Value* value = (Value*)malloc(sizeof(Value)); 74 | value->type = type; 75 | value->data = data; 76 | return value; 77 | } 78 | 79 | Binding* alloc_binding(Value* variable, Value* value) 80 | { 81 | Binding* binding = (Binding*)malloc(sizeof(Binding)); 82 | binding->symbol = variable->data; 83 | binding->value = (Value*)malloc(sizeof(Value)); 84 | binding->value->type = value->type; 85 | binding->value->data = value->data; 86 | return binding; 87 | } 88 | 89 | List* alloc_binding_list(List* variables, List* values) 90 | { 91 | List* binding_list = alloc_list(); 92 | Node* current_variable = variables->first; 93 | Node* current_value = values->first; 94 | for (int i = 0; i < variables->length; i++) { 95 | list_append(binding_list, alloc_value(TYPE_BINDING, alloc_binding(current_variable->value, current_value->value))); 96 | current_variable = current_variable->next; 97 | current_value = current_value->next; 98 | } 99 | return binding_list; 100 | } 101 | 102 | Procedure* alloc_procedure(List* variables, Value* code, List* parent_environment, int type) 103 | { 104 | Procedure* procedure = (Procedure*)malloc(sizeof(Procedure)); 105 | procedure->type = (unsigned char)type; 106 | procedure->free_variables = variables; 107 | procedure->code = code; 108 | procedure->environment = parent_environment; 109 | return procedure; 110 | } 111 | 112 | Value* apply(Procedure* procedure, List* arguments, List* environment) 113 | { 114 | // If procedure is a LAMBDA or PRIMITIVE, argument and variable list lengths must agree 115 | if (procedure->type == PROCEDURE_LAMBDA || (procedure->type == PROCEDURE_PRIMITIVE && procedure->free_variables->length != 0)) 116 | if (procedure->free_variables->length != arguments->length) 117 | return alloc_value(TYPE_ERROR, "procedure given wrong number of arguments"); 118 | 119 | // Primitive proceudres are executed by calling the appropriate C function through a function pointer 120 | if (procedure->type == PROCEDURE_PRIMITIVE) 121 | return ((Value* (*)(List*))procedure->code)(arguments); 122 | 123 | // If procedure is a VARLAMBDA (.. in parameter list), 124 | if (procedure->type == PROCEDURE_VARLAMBDA) { 125 | int required_args = procedure->free_variables->length - 1; 126 | //printf("VARLAM: %i\n", required_args); //value_print(alloc_value(TYPE_LIST, arguments)); printf("\n"); 127 | // Enough arguments supplied? 128 | if (arguments->length < required_args) 129 | return alloc_value(TYPE_ERROR, "procedure given too few arguments"); 130 | else { 131 | // Basically we wrap the rest of the arguments into a new list (destructively): 132 | List* rest_args = alloc_list(); 133 | rest_args->length = arguments->length - required_args; 134 | if (arguments->length != required_args) { 135 | rest_args->first = list_nth_node(arguments, required_args); 136 | rest_args->last = arguments->last; 137 | } 138 | Node* rest_arg_node = (Node*)malloc(sizeof(Node)); 139 | rest_arg_node->value = alloc_value(TYPE_LIST, rest_args); 140 | arguments->length = procedure->free_variables->length; 141 | if (required_args == 0) 142 | arguments->first = rest_arg_node; 143 | else 144 | list_nth_node(arguments, required_args - 1)->next = rest_arg_node; 145 | } 146 | } 147 | 148 | // Make a new environment where the new bindings are added to the parent environment 149 | List* new_environment = alloc_binding_list(procedure->free_variables, arguments); 150 | list_copy_new(new_environment, procedure->environment); 151 | list_copy_new(new_environment, environment); 152 | 153 | // Finally, evaluate the procedure 154 | return eval(procedure->code, new_environment); 155 | } 156 | 157 | Value* eval(Value* expression, List* environment) 158 | { 159 | //printf("EVAL: "); value_print(expression); printf("\n"); 160 | if (expression->type == TYPE_INTEGER || expression->type == TYPE_ERROR || expression->type == TYPE_PROCEDURE) 161 | return expression; 162 | if (expression->type == TYPE_SYMBOL && !strcmp(expression->data, "NIL")) 163 | return expression; 164 | if (expression->type == TYPE_SYMBOL) 165 | return environment_lookup(environment, expression->data); 166 | 167 | if (expression->type == TYPE_LIST) { 168 | List* list = (List*)expression->data; 169 | if (list->length == 0) 170 | return expression; 171 | 172 | // If the first element is a symbol, it might refer to an operator 173 | if (list->first->value->type == TYPE_SYMBOL) { 174 | char* symbol = (char*)list->first->value->data; 175 | 176 | // Check for operator match 177 | for (int i = 0; i < num_operators; i++) { 178 | if (!strcmp(operators[i].name, symbol)) { 179 | 180 | // Call the operator 181 | List arguments = list_pop(list); 182 | return apply_operator(&operators[i], &arguments, environment); 183 | } 184 | } 185 | } 186 | 187 | // If first element is not an operator, the list is a function call, and each element is evaluated: 188 | List evaluated_list = {0, NULL, NULL}; 189 | Node* current = list->first; 190 | for (int i = 0; i < list->length; i++) { 191 | Value* element = eval(current->value, environment); 192 | if (element->type == TYPE_ERROR) return element; 193 | list_append(&evaluated_list, element); 194 | current = current->next; 195 | } 196 | 197 | // If the first element evaluated to a procedure, apply the procedure to the arguments: 198 | if (evaluated_list.first->value->type == TYPE_PROCEDURE) { 199 | List arguments = list_pop(&evaluated_list); 200 | return apply((Procedure*)evaluated_list.first->value->data, &arguments, environment); 201 | } 202 | else 203 | return alloc_value(TYPE_ERROR, "first element of list not operator or procedure"); 204 | } 205 | } 206 | 207 | void test_repl() 208 | { 209 | char expression[8000]; 210 | List* env = setup_environment(); 211 | Value* result; 212 | 213 | FILE* file = fopen("stdlib.lisp", "r"); 214 | fseek(file, 0, SEEK_END); 215 | int size = ftell(file); 216 | rewind(file); 217 | fread(expression, 1, size, file); 218 | expression[size] = 0; 219 | strip_spaces(expression); 220 | result = eval(parse_string(expression), env); 221 | 222 | while(1) { 223 | printf("LISP> "); 224 | if (!strcmp(fgets(expression, sizeof(expression), stdin), "QUIT\n")) break; 225 | expression[strlen(expression) - 1] = 0; 226 | strip_spaces(expression); 227 | result = eval(parse_string(expression), env); 228 | value_print(result); 229 | printf("\n"); 230 | } 231 | } 232 | 233 | int main() 234 | { 235 | test_repl(); 236 | return 0; 237 | } 238 | -------------------------------------------------------------------------------- /src/lisp.h: -------------------------------------------------------------------------------- 1 | #define TYPE_INTEGER 0 2 | #define TYPE_SYMBOL 1 3 | #define TYPE_LIST 2 4 | #define TYPE_PROCEDURE 3 5 | #define TYPE_BINDING 4 6 | #define TYPE_ERROR 5 7 | #define TYPE_OPERATOR 6 8 | 9 | extern const char* type_names[]; 10 | 11 | #define PROCEDURE_PRIMITIVE 0 12 | #define PROCEDURE_LAMBDA 1 13 | #define PROCEDURE_VARLAMBDA 2 14 | 15 | typedef struct { 16 | int type; 17 | void* data; 18 | } Value; 19 | 20 | typedef struct Node 21 | { 22 | Value* value; 23 | struct Node* next; 24 | } Node; 25 | 26 | typedef struct 27 | { 28 | int length; 29 | struct Node* first; 30 | struct Node* last; 31 | } List; 32 | 33 | typedef struct { 34 | unsigned char type; 35 | unsigned char args; 36 | List* environment; 37 | List* free_variables; 38 | void* code; 39 | } Procedure; 40 | 41 | typedef struct { 42 | char* symbol; 43 | Value* value; 44 | } Binding; 45 | 46 | typedef struct { 47 | char* name; 48 | int num_arguments; 49 | char argument_flags[3]; 50 | Value* (*function) (List*, List*); 51 | } Operator; 52 | 53 | int compare_values(Value*, Value*); 54 | Value* environment_lookup(List*, char*); 55 | Value* alloc_value(int, void*); 56 | Binding* alloc_binding(Value*, Value*); 57 | List* alloc_binding_list(List*, List*); 58 | Procedure* alloc_procedure(List*, Value*, List*, int); 59 | Value* apply(Procedure*, List*, List*); 60 | Value* eval(Value*, List*); 61 | List* setup_environment(); 62 | void value_print(Value*); 63 | int check_number(char*); 64 | int check_symbol(char*); 65 | int check_list(char*); 66 | int strcount(char*, char); 67 | char* string_uppercase(char*); 68 | Value* parse_string(char*); 69 | void list_append_parsed_string(List*, char*, int, int); 70 | List* parse_list_string(char*); 71 | int* allocate_integer(int); 72 | 73 | extern Operator operators[]; 74 | -------------------------------------------------------------------------------- /src/list.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "lisp.h" 3 | #include "list.h" 4 | 5 | List* alloc_list() 6 | { 7 | List* list = (List*)malloc(sizeof(List)); 8 | list->length = 0; 9 | list->first = NULL; 10 | list->last = NULL; 11 | return list; 12 | } 13 | 14 | Node* list_nth_node(List* lst, int index) 15 | { 16 | Node* current = lst->first; 17 | for (int i = 0; i < index; i++) 18 | current = current->next; 19 | return current; 20 | } 21 | 22 | void list_delete(List* lst, int index) 23 | { 24 | Node* current = lst->first; 25 | Node* last; 26 | int i; 27 | if (index == 0) 28 | lst->first = current->next; 29 | else { 30 | for (i = 0; i < index; i++) { 31 | last = current; 32 | current = current->next; 33 | } 34 | last->next = current->next; 35 | } 36 | if (i == lst->length - 1) 37 | lst->last = last; 38 | list_node_free(current); 39 | lst->length--; 40 | } 41 | 42 | List* list_copy_omit(List* lst, int index) 43 | { 44 | List* new = alloc_list(); 45 | Node* current = lst->first; 46 | for (int i = 0; i < lst->length; i++) { 47 | if (i != index) 48 | list_append(new, current->value); 49 | current = current->next; 50 | } 51 | return new; 52 | } 53 | 54 | List* list_copy(List* source) 55 | { 56 | List* new = alloc_list(); 57 | Node* current = source->first; 58 | for (int i = 0; i < source->length; i++) { 59 | list_append(new, current->value); 60 | current = current->next; 61 | } 62 | return new; 63 | } 64 | 65 | void list_copy_new(List* dest, List* source) 66 | { 67 | Node* current = source->first; 68 | for (int i = 0; i < source->length; i++) { 69 | if (list_find(dest, current->value) == -1) 70 | list_append(dest, current->value); 71 | current = current->next; 72 | } 73 | } 74 | 75 | void list_append(List* list, Value* new_item) 76 | { 77 | Node* new = (Node*)malloc(sizeof(Node)); 78 | new->value = (Value*)malloc(sizeof(Value)); 79 | new->value->type = new_item->type; 80 | new->value->data = new_item->data; 81 | new->next = NULL; 82 | if (list->length == 0) 83 | list->first = new; 84 | else 85 | list->last->next = new; 86 | list->last = new; 87 | list->length++; 88 | } 89 | 90 | int list_find(List* list, Value* item) 91 | { 92 | if (list->length == 0) return -1; 93 | Node* current = list->first; 94 | for (int i = 0; i < list->length; i++) { 95 | if (compare_values(current->value, item)) return i; 96 | current = current->next; 97 | } 98 | return -1; 99 | } 100 | 101 | void list_node_free(Node* node) 102 | { 103 | free(node->value); 104 | free(node); 105 | } 106 | 107 | void list_destruct(List* list) 108 | { 109 | Node* current = list->first; 110 | for (int i = 0; i < list->length; i++) { 111 | list_node_free(current); 112 | } 113 | free(list); 114 | } 115 | 116 | List list_pop(List* list) 117 | { 118 | List new_head = { 119 | list->length - 1, 120 | list->first->next, 121 | list->last 122 | }; 123 | return new_head; 124 | } 125 | -------------------------------------------------------------------------------- /src/list.h: -------------------------------------------------------------------------------- 1 | 2 | List* alloc_list(); 3 | Node* list_nth_node(List*, int); 4 | void list_delete(List*, int); 5 | List* list_copy(List*); 6 | List* list_copy_omit(List*, int); 7 | void list_copy_new(List*, List*); 8 | void list_append(List*, Value*); 9 | int list_find(List*, Value*); 10 | void list_node_free(Node*); 11 | void list_destruct(List*); 12 | List list_pop(List*); 13 | -------------------------------------------------------------------------------- /src/operators.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "lisp.h" 5 | #include "list.h" 6 | #include "operators.h" 7 | 8 | #define EVAL 0 9 | #define NO_EVAL 1 10 | 11 | /* Internal declarations */ 12 | Value* operator_if(List*, List*); 13 | Value* operator_define(List*, List*); 14 | Value* operator_set(List*, List*); 15 | Value* operator_quote(List*, List*); 16 | Value* operator_lambda(List*, List*); 17 | Value* operator_let(List*, List*); 18 | Value* operator_prog(List*, List*); 19 | Value* operator_cond(List*, List*); 20 | Value* operator_eval(List*, List*); 21 | 22 | Operator operators[] = { 23 | {"IF", 3, {EVAL, NO_EVAL, NO_EVAL}, &operator_if}, 24 | {"QUOTE", 1, {NO_EVAL}, &operator_quote}, 25 | {"DEF", 2, {NO_EVAL, EVAL}, &operator_define}, 26 | {"\\", 2, {NO_EVAL, NO_EVAL}, &operator_lambda}, 27 | {"SET!", 2, {NO_EVAL, EVAL}, &operator_set}, 28 | {"LET", 2, {NO_EVAL, NO_EVAL}, &operator_let}, 29 | {"DO", 0, {}, &operator_prog}, 30 | {":", 0, {}, &operator_prog}, 31 | {"COND", 0, {}, &operator_cond}, 32 | //{"EVAL", 1, {EVAL}, &operator_eval} 33 | }; 34 | 35 | Value* apply_operator(Operator* operator, List* arguments, List* environment) 36 | { 37 | Node* current_arg = arguments->first; 38 | List evaluated_args = {}; 39 | if (operator->num_arguments != 0 && operator->num_arguments != arguments->length) 40 | return alloc_value(TYPE_ERROR, "wrong number of arguments for operator"); 41 | for (int i = 0; i < arguments->length; i++) { 42 | Value* result = current_arg->value; 43 | if (operator->num_arguments != 0) { 44 | if ((operator->argument_flags)[i] == EVAL) { 45 | result = eval(current_arg->value, environment); 46 | if (result->type == TYPE_ERROR) return result; 47 | } 48 | } 49 | list_append(&evaluated_args, result); 50 | current_arg = current_arg->next; 51 | } 52 | return operator->function(&evaluated_args, environment); 53 | } 54 | 55 | Value* operator_if(List* arguments, List* environment) 56 | { 57 | Value* test_value = arguments->first->value; 58 | Value* true_exp = arguments->first->next->value; 59 | Value* false_exp = arguments->first->next->next->value; 60 | 61 | if (test_value->type == TYPE_SYMBOL && !strcmp(test_value->data, "NIL")) 62 | return eval(false_exp, environment); 63 | return eval(true_exp, environment); 64 | } 65 | 66 | Value* operator_quote(List* arguments, List* environment) 67 | { 68 | return arguments->first->value; 69 | } 70 | 71 | Value* operator_define(List* arguments, List* environment) 72 | { 73 | Value* symbol = arguments->first->value; 74 | Value* value = arguments->first->next->value; 75 | 76 | if (!symbol->type == TYPE_SYMBOL) 77 | return alloc_value(TYPE_ERROR, "DEFINE: variable name must be symbolic"); 78 | 79 | list_append(environment, alloc_value(TYPE_BINDING, alloc_binding(symbol, value))); 80 | return symbol; 81 | } 82 | 83 | Value* operator_lambda(List* arguments, List* environment) 84 | { 85 | Value* arglist = arguments->first->value; 86 | Value* code = arguments->first->next->value; 87 | 88 | if (arglist->type != TYPE_LIST) 89 | return alloc_value(TYPE_ERROR, "LAMBDA: no argument list"); 90 | Value ellipsis; 91 | List* arglst = (List*)arglist->data; 92 | ellipsis.type = TYPE_SYMBOL; 93 | ellipsis.data = ".."; 94 | int index; 95 | int type = PROCEDURE_LAMBDA; 96 | // If we find an ellipsis, check if it's correctly placed: 97 | if ((index = list_find(arglst, &ellipsis)) != -1) { 98 | if (index == arglst->length - 2) { 99 | // if so, it will be a procedure of type TYPE_VARIABLE_LAMBDA, and we simply remove the .. 100 | type = PROCEDURE_VARLAMBDA; 101 | arglst = list_copy_omit(arglst, index); 102 | } 103 | else 104 | return alloc_value(TYPE_ERROR, "LAMBDA: malformed argument list"); 105 | } 106 | return alloc_value(TYPE_PROCEDURE, alloc_procedure(arglst, code, environment, type)); 107 | } 108 | 109 | Value* operator_set(List* arguments, List* environment) 110 | { 111 | Value* symbol = arguments->first->value; 112 | Value* value = arguments->first->next->value; 113 | 114 | if (!(symbol->type == TYPE_SYMBOL)) 115 | return alloc_value(TYPE_ERROR, "SET: variable name must be symbolic"); 116 | Value* binding_value = environment_lookup(environment, symbol->data); 117 | if (binding_value->type == TYPE_ERROR) return binding_value; 118 | binding_value->type = value->type; 119 | binding_value->data = value->data; 120 | return symbol; 121 | } 122 | 123 | Value* operator_let(List* arguments, List* environment) 124 | { 125 | Value* var_defs = arguments->first->value; 126 | Value* body = arguments->first->next->value; 127 | 128 | if (var_defs->type != TYPE_LIST) 129 | return alloc_value(TYPE_ERROR, "LET: no variable definition list"); 130 | List* var_def_list = (List*)var_defs->data; 131 | List variable_names = {0, NULL, NULL}; 132 | List initial_values = {0, NULL, NULL}; 133 | Node* current = ((List*)var_defs->data)->first; 134 | 135 | for (int i = 0; i < var_def_list->length; i++) { 136 | if (current->value->type == TYPE_LIST) { 137 | List* def = (List*)current->value->data; 138 | if (def->length != 2 || def->first->value->type != TYPE_SYMBOL) 139 | return alloc_value(TYPE_ERROR, "LET: malformed binding list"); 140 | list_append(&variable_names, alloc_value(TYPE_SYMBOL, def->first->value->data)); 141 | list_append(&initial_values, def->first->next->value); 142 | } 143 | else return alloc_value(TYPE_ERROR, "LET: expected list in binding list"); 144 | current = current->next; 145 | } 146 | // Create an anonymous procedure to perform the local bindings 147 | Procedure pseudo_proc; 148 | pseudo_proc.type = PROCEDURE_LAMBDA; 149 | pseudo_proc.environment = environment; 150 | pseudo_proc.free_variables = &variable_names; 151 | pseudo_proc.code = body; 152 | 153 | // Construct a call to the procedure 154 | List pseudo_call = {0, NULL, NULL}; 155 | list_append(&pseudo_call, alloc_value(TYPE_PROCEDURE, &pseudo_proc)); 156 | pseudo_call.length += initial_values.length; 157 | pseudo_call.first->next = initial_values.first; 158 | 159 | // ... and call it: 160 | return eval(alloc_value(TYPE_LIST, &pseudo_call), environment); 161 | } 162 | 163 | Value* operator_prog(List* arguments, List* environment) 164 | { 165 | Value* result; 166 | Node* current = arguments->first; 167 | for (int i = 0; i < arguments->length; i++) { 168 | result = eval(current->value, environment); 169 | if (result->type == TYPE_ERROR) return result; 170 | current = current->next; 171 | } 172 | return result; 173 | } 174 | 175 | Value* operator_cond(List* arguments, List* environment) 176 | { 177 | Node* current_clause = arguments->first; 178 | Value* result; 179 | 180 | for (int i = 0; i < arguments->length; i++) { 181 | if (current_clause->value->type != TYPE_LIST) 182 | return alloc_value(TYPE_ERROR, "COND: expects lists of form (test e1 e2 ... en)"); 183 | List* clause = (List*)current_clause->value->data; 184 | if (clause->length < 2) 185 | return alloc_value(TYPE_ERROR, "COND: malformed clause"); 186 | result = eval(clause->first->value, environment); 187 | if (result->type == TYPE_ERROR) return result; 188 | if (!(result->type == TYPE_SYMBOL && !strcmp(result->data, "NIL"))) { 189 | List prog_exp = {0, NULL, NULL}; 190 | list_append(&prog_exp, alloc_value(TYPE_SYMBOL, "DO")); 191 | prog_exp.first->next = clause->first->next; 192 | prog_exp.length = clause->length; 193 | return eval(alloc_value(TYPE_LIST, &prog_exp), environment); 194 | } 195 | current_clause = current_clause->next; 196 | } 197 | return result; 198 | } 199 | 200 | Value* operator_eval(List* arguments, List* environment) 201 | { 202 | return arguments->first->value; 203 | } 204 | 205 | -------------------------------------------------------------------------------- /src/operators.h: -------------------------------------------------------------------------------- 1 | /* lispc - operators */ 2 | 3 | Value* apply_operator(Operator*, List*, List*); 4 | 5 | #define num_operators 9 6 | -------------------------------------------------------------------------------- /src/parser.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include "lisp.h" 6 | #include "list.h" 7 | 8 | int check_number(char* str) 9 | { 10 | for (int i = 0; i < strlen(str); i++) { 11 | if (strpbrk(str + i, "0123456789") == NULL) 12 | return 0; 13 | } 14 | return 1; 15 | } 16 | 17 | int check_symbol(char* str) 18 | { 19 | return strchr(str, '(') == 0 && strchr(str, ')') == 0 && strchr(str, ' ') == 0; 20 | } 21 | 22 | int strcount(char* str, char c) 23 | { 24 | int count = 0; 25 | for (int i = 0; i < strlen(str); i++) 26 | if (str[i] == c) count++; 27 | return count; 28 | } 29 | 30 | int check_list(char* str) 31 | { 32 | return strcount(str, '(') == strcount(str, ')'); 33 | } 34 | 35 | char* string_uppercase(char* string) 36 | { 37 | for (int i = 0; i < strlen(string); i++) 38 | string[i] = toupper(string[i]); 39 | return string; 40 | } 41 | 42 | int check_quote(char* str) 43 | { 44 | return *str == '\''; 45 | } 46 | 47 | void strip_spaces(char* string) 48 | { 49 | int j = 0; int spaces = 0; 50 | int length = strlen(string); 51 | for (int i = 0; i < length; i++) { 52 | if (string[i] != ' ' && string[i] != '\n' && string[i] != '\t') { 53 | spaces = 0; 54 | string[j++] = string[i]; 55 | } 56 | else { 57 | spaces++; 58 | if (spaces == 1 && i > 1 && i < length - 2 && string[i-1] != '(' && string[i+1] != ')') 59 | string[j++] = ' '; 60 | } 61 | } 62 | string[j] = 0; 63 | } 64 | 65 | Value* parse_string(char* string) 66 | { 67 | Value* value; 68 | if (check_quote(string)) { 69 | List* quote_exp = alloc_list(); 70 | list_append(quote_exp, alloc_value(TYPE_SYMBOL, "QUOTE")); 71 | list_append(quote_exp, parse_string(string+1)); 72 | value = alloc_value(TYPE_LIST, quote_exp); 73 | } 74 | else if (check_number(string)) 75 | value = alloc_value(TYPE_INTEGER, allocate_integer(atoi(string))); 76 | else if (check_symbol(string)) 77 | value = alloc_value(TYPE_SYMBOL, string_uppercase(string)); 78 | else if (check_list(string)) 79 | value = alloc_value(TYPE_LIST, parse_list_string(string)); 80 | else 81 | value = alloc_value(TYPE_ERROR, "Parse error!"); 82 | return value; 83 | } 84 | 85 | void list_append_parsed_string(List* list, char* string, int start, int end) 86 | { 87 | int length = end - start; 88 | char* element = (char*)malloc(sizeof(char) * (length + 1)); 89 | strncpy(element, string + start, length); 90 | element[length] = 0; 91 | list_append(list, parse_string(element)); 92 | } 93 | 94 | List* parse_list_string(char* string) 95 | { 96 | List* expression = alloc_list(); 97 | int length = strlen(string); 98 | int level = 0; 99 | int last_break = 1; 100 | if (strlen(string) == 2) return expression; 101 | if (string[0] == '(' && string[length - 1] == ')') { 102 | for (int i = 1; i < length - 1; i++) { 103 | switch (string[i]) { 104 | case '(': 105 | level++; break; 106 | case ')': 107 | level--; break; 108 | case ' ': 109 | if (level == 0) { 110 | list_append_parsed_string(expression, string, last_break, i); 111 | last_break = i+1; 112 | } 113 | break; 114 | } 115 | } 116 | list_append_parsed_string(expression, string, last_break, length - 1); 117 | } 118 | return expression; 119 | } 120 | 121 | 122 | 123 | 124 | 125 | -------------------------------------------------------------------------------- /src/primitives.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "lisp.h" 4 | #include "list.h" 5 | #include "primitives.h" 6 | 7 | #define OPERATION_PLUS 0 8 | #define OPERATION_MINUS 1 9 | #define OPERATION_MULTIPLY 2 10 | 11 | /* Internal declarations */ 12 | Procedure* alloc_primitive_procedure(Value* (*) (List*), int); 13 | void append_primtive_procedure(List*, char*, int num_args, Value* (*) (List*)); 14 | Value* primitive_plus(List*); 15 | Value* primitive_eq(List*); 16 | Value* primitive_greater(List*); 17 | Value* primitive_less(List*); 18 | Value* primitive_greatereq(List*); 19 | Value* primitive_lesseq(List*); 20 | Value* primitive_list(List*); 21 | Value* primitive_first(List*); 22 | Value* primitive_rest(List*); 23 | Value* primitive_push(List*); 24 | Value* primitive_mod(List*); 25 | Value* primitive_print(List*); 26 | Value* primitive_apply(List*); 27 | Value* primitive_minus(List*); 28 | Value* primitive_multiply(List*); 29 | Value* primitive_type(List*); 30 | 31 | Procedure* alloc_primitive_procedure(Value* (*code) (List*), int num_args) 32 | { 33 | Procedure* procedure = (Procedure*)malloc(sizeof(Procedure)); 34 | 35 | procedure->type = PROCEDURE_PRIMITIVE; 36 | procedure->environment = NULL; 37 | procedure->free_variables = alloc_list(); 38 | procedure->free_variables->length = num_args; 39 | procedure->code = code; 40 | return procedure; 41 | } 42 | 43 | void append_primitive_procedure(List* env, char* name, int num_args, Value* (*code) (List*)) 44 | { 45 | list_append(env, alloc_value(TYPE_BINDING, alloc_binding(alloc_value(TYPE_SYMBOL, name), 46 | alloc_value(TYPE_PROCEDURE, alloc_primitive_procedure(code, num_args))))); 47 | } 48 | 49 | List* setup_environment() 50 | { 51 | List* env = alloc_list(); 52 | 53 | // fill up 'em procedures ... 54 | append_primitive_procedure(env, "_+", 0, &primitive_plus); 55 | append_primitive_procedure(env, "=", 0, &primitive_eq); 56 | append_primitive_procedure(env, "LIST", 0, &primitive_list); 57 | append_primitive_procedure(env, "_FIRST", 1, &primitive_first); 58 | append_primitive_procedure(env, "_REST", 1, &primitive_rest); 59 | append_primitive_procedure(env, "_PUSH", 2, &primitive_push); 60 | append_primitive_procedure(env, "_%", 2, &primitive_mod); 61 | append_primitive_procedure(env, "_PRINT", 1, &primitive_print); 62 | append_primitive_procedure(env, "APPLY", 2, &primitive_apply); 63 | append_primitive_procedure(env, "_>", 2, &primitive_greater); 64 | append_primitive_procedure(env, "_<", 2, &primitive_less); 65 | append_primitive_procedure(env, "_<=", 2, &primitive_lesseq); 66 | append_primitive_procedure(env, "_>=", 2, &primitive_greatereq); 67 | append_primitive_procedure(env, "_-", 0, &primitive_minus); 68 | append_primitive_procedure(env, "_*", 0, &primitive_multiply); 69 | append_primitive_procedure(env, "TYPE", 1, &primitive_type); 70 | 71 | return env; 72 | } 73 | 74 | Value* apply_arithmetic_primitive(List* arguments, int operation) 75 | { 76 | Node* current_argument = arguments->first; 77 | 78 | int* result = (int*)malloc(sizeof(int)); 79 | for (int i = 0; i < arguments->length; i++) { 80 | if (current_argument->value->type != TYPE_INTEGER) 81 | return alloc_value(TYPE_ERROR, "expects integer arguments"); 82 | if (i == 0) *result = *(int*)current_argument->value->data; 83 | else { 84 | if (operation == OPERATION_PLUS) 85 | *result += *(int*)(current_argument->value->data); 86 | if (operation == OPERATION_MINUS) 87 | *result -= *(int*)current_argument->value->data; 88 | if (operation == OPERATION_MULTIPLY) 89 | *result *= *(int*)current_argument->value->data; 90 | } 91 | current_argument = current_argument->next; 92 | } 93 | return alloc_value(TYPE_INTEGER, result); 94 | } 95 | 96 | Value* primitive_plus(List* arguments) 97 | { 98 | return apply_arithmetic_primitive(arguments, OPERATION_PLUS); 99 | } 100 | 101 | Value* primitive_minus(List* arguments) 102 | { 103 | return apply_arithmetic_primitive(arguments, OPERATION_MINUS); 104 | } 105 | 106 | Value* primitive_multiply(List* arguments) 107 | { 108 | return apply_arithmetic_primitive(arguments, OPERATION_MULTIPLY); 109 | } 110 | 111 | Value* primitive_eq(List* arguments) 112 | { 113 | Node* current_argument = arguments->first; 114 | for (int i = 0; i < arguments->length - 1; i++) { 115 | if (!compare_values(current_argument->value, current_argument->next->value)) 116 | return alloc_value(TYPE_SYMBOL, "NIL"); 117 | current_argument = current_argument->next; 118 | } 119 | return alloc_value(TYPE_SYMBOL, "T"); 120 | } 121 | 122 | Value* primitive_less(List* arguments) 123 | { 124 | Value* a = arguments->first->value; 125 | Value* b = arguments->last->value; 126 | if (a->type != TYPE_INTEGER || b->type != TYPE_INTEGER) 127 | return alloc_value(TYPE_ERROR, "arguments not integers"); 128 | else 129 | return alloc_value(TYPE_SYMBOL, (*(int*)a->data < *(int*)b->data) ? "T" : "NIL"); 130 | } 131 | 132 | Value* primitive_greater(List* arguments) 133 | { 134 | List lst = {2, arguments->last, arguments->first}; 135 | return primitive_less(&lst); 136 | } 137 | 138 | Value* primitive_lesseq(List* arguments) 139 | { 140 | return primitive_less(arguments) || primitive_eq(arguments); 141 | } 142 | 143 | Value* primitive_greatereq(List* arguments) 144 | { 145 | return primitive_greater(arguments) || primitive_eq(arguments); 146 | } 147 | 148 | Value* primitive_list(List* arguments) 149 | { 150 | return alloc_value(TYPE_LIST, list_copy(arguments)); 151 | } 152 | 153 | Value* primitive_first(List* arguments) 154 | { 155 | Value* arg = arguments->first->value; 156 | 157 | if (arg->type != TYPE_LIST) 158 | alloc_value(TYPE_ERROR, "expects list"); 159 | else { 160 | List* lst = (List*)arg->data; 161 | if (lst->length == 0) 162 | return alloc_value(TYPE_SYMBOL, "NIL"); 163 | else 164 | return lst->first->value; 165 | } 166 | } 167 | 168 | Value* primitive_rest(List* arguments) 169 | { 170 | Value* arg = arguments->first->value; 171 | 172 | if (arg->type != TYPE_LIST) 173 | alloc_value(TYPE_ERROR, "expects list"); 174 | else { 175 | List* lst = (List*)arg->data; 176 | if (lst->length < 1) 177 | return arg; 178 | else { 179 | List* rest_lst = alloc_list(); 180 | rest_lst->length = lst->length - 1; 181 | rest_lst->first = lst->first->next; 182 | rest_lst->last = lst->last; 183 | return alloc_value(TYPE_LIST, rest_lst); 184 | } 185 | } 186 | } 187 | 188 | Value* primitive_push(List* arguments) 189 | { 190 | Value* val = arguments->first->value; 191 | Value* list = arguments->last->value; 192 | 193 | if (list->type != TYPE_LIST) 194 | return alloc_value(TYPE_ERROR, "PUSH expects second argument to be a list."); 195 | List* new_list = alloc_list(); 196 | List* old_lst = (List*)list->data; 197 | Node* first_node = (Node*)malloc(sizeof(Node)); 198 | first_node->value = val; 199 | first_node->next = old_lst->first; 200 | new_list->length = old_lst->length + 1; 201 | new_list->first = first_node; 202 | new_list->last = old_lst->last; 203 | return alloc_value(TYPE_LIST, new_list); 204 | } 205 | 206 | Value* primitive_apply(List* arguments) 207 | { 208 | Value* proc = arguments->first->value; 209 | Value* list = arguments->last->value; 210 | List env = {}; 211 | 212 | if (proc->type != TYPE_PROCEDURE) 213 | return alloc_value(TYPE_ERROR, "APPLY expects a procedure as first argument."); 214 | if (list->type != TYPE_LIST) 215 | return alloc_value(TYPE_ERROR, "APPLY expects list as second argument."); 216 | return apply((Procedure*)proc->data, (List*)list->data, &env); 217 | } 218 | 219 | Value* primitive_mod(List* arguments) 220 | { 221 | Value* a = arguments->first->value; 222 | Value* b = arguments->first->next->value; 223 | 224 | if (a->type != TYPE_INTEGER || b->type != TYPE_INTEGER) 225 | return alloc_value(TYPE_ERROR, "MOD requires numeric arguments"); 226 | return alloc_value(TYPE_INTEGER, allocate_integer(*(int*)a->data % *(int*)b->data)); 227 | } 228 | 229 | Value* primitive_print(List* arguments) 230 | { 231 | value_print(arguments->first->value); printf("\n"); 232 | return arguments->first->value; 233 | } 234 | 235 | Value* primitive_type(List* arguments) 236 | { 237 | Value* val = arguments->first->value; 238 | 239 | return alloc_value(TYPE_SYMBOL, type_names[val->type]); 240 | } 241 | -------------------------------------------------------------------------------- /src/primitives.h: -------------------------------------------------------------------------------- 1 | /* Lispc - primitive procedures */ 2 | 3 | Value* apply_arithmetic_primitive(List*, int); 4 | -------------------------------------------------------------------------------- /src/printer.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "lisp.h" 4 | #include "list.h" 5 | 6 | void value_print(Value* value) 7 | { 8 | switch (value->type) { 9 | case TYPE_INTEGER: 10 | printf("%i", *(int*)value->data); 11 | break; 12 | case TYPE_SYMBOL: 13 | printf("%s", (char*)value->data); 14 | break; 15 | case TYPE_PROCEDURE: 16 | printf("[PROCEDURE]"); 17 | break; 18 | case TYPE_ERROR: 19 | printf("ERROR! %s", (char*)value->data); 20 | break; 21 | case TYPE_LIST: 22 | { 23 | List* lst = (List*)value->data; 24 | Node* current = lst->first; 25 | printf("("); 26 | for (int i = 0; i < lst->length; i++) { 27 | value_print(current->value); 28 | if (i < lst->length - 1) 29 | printf(" "); 30 | current = current->next; 31 | } 32 | printf(")"); 33 | break; 34 | } 35 | case TYPE_BINDING: { 36 | printf("%s -> ", ((Binding*)value->data)->symbol); 37 | value_print(((Binding*)value->data)->value); printf("\n"); 38 | } 39 | break; 40 | } 41 | } 42 | 43 | -------------------------------------------------------------------------------- /src/stdlib.lisp: -------------------------------------------------------------------------------- 1 | (: 2 | (def empty? (\ (x) (= x ()))) 3 | (def symbol? (\ (x) (= (type x) 'symbol))) 4 | (def second (\ (x) (_first (_rest x)))) 5 | (def list? (\ (x) (= (type x) 'list))) 6 | 7 | (def count 8 | (\ (list) 9 | (if (empty? list) 10 | 0 11 | (_+ 1 (count (_rest list)))))) 12 | 13 | (def map 14 | (\ (f list) 15 | (if (empty? list) 16 | () 17 | (_push (f (_first list)) 18 | (map f (_rest list)))))) 19 | 20 | (def filter 21 | (\ (pred list) 22 | (if (empty? list) 23 | () 24 | (let ((f (_first list))) 25 | (if (pred f) 26 | (_push f (filter pred (_rest list))) 27 | (filter pred (_rest list))))))) 28 | 29 | (def reduce 30 | (\ (f list) 31 | (if (= (count list) 1) 32 | (_first list) 33 | (f (_first list) 34 | (reduce f (_rest list)))))) 35 | 36 | (def every? (\ (pred lst) 37 | (if (empty? lst) 38 | 'true 39 | (if (pred (_first lst)) 40 | (every? pred (_rest lst)) 41 | nil)))) 42 | 43 | (def join (\ (lsta lstb) 44 | (if (empty? lsta) 45 | lstb 46 | (join (_rest lsta) (_push (_first lsta) lstb))))) 47 | 48 | (def find-by (\ (f element lst) 49 | (if (empty? lst) 50 | nil 51 | (if (= element (f (_first lst))) 52 | (_first lst) 53 | (find-by f element (_rest lst)))))) 54 | 55 | (def _generic-table '()) 56 | (def _generic-name _first) 57 | (def _generic-fn _first) 58 | (def _generic-imps second) 59 | (def _generic-types second) 60 | 61 | (def _table-update-dispatch (\ (op fn types) 62 | (list (_generic-name op) (_push (list fn types) (_generic-imps op))))) 63 | 64 | (def _table-add! (\ (operation) 65 | (if (find-by _first operation _generic-table) 66 | nil 67 | (set! _generic-table 68 | (_push (list operation '()) _generic-table))))) 69 | 70 | (def _table-add-dispatch! (\ (name fn types) 71 | (if (find-by _generic-name name _generic-table) 72 | (: (set! _generic-table 73 | (map (\ (generic) 74 | (if (= (_generic-name generic) name) 75 | (_table-update-dispatch generic fn types) 76 | generic)) 77 | _generic-table)) 78 | name) 79 | 'no-generic))) 80 | 81 | (def _apply-generic (\ (name .. args) 82 | (let ((generic (find-by _generic-name name _generic-table))) 83 | (if generic 84 | (let ((imps (_generic-imps generic)) 85 | (arg-types (map type args))) 86 | (let ((imp (find-by _generic-types arg-types imps))) 87 | (if imp 88 | (apply (_generic-fn imp) args) 89 | (let ((imp (filter (\ (x) (symbol? (_generic-types x))) imps))) 90 | (if (empty? imp) 91 | 'error-no-match 92 | (if (every? (\ (x) (= x (_generic-types (_first imp)))) arg-types) 93 | (apply (_generic-fn (_first imp)) args) 94 | 'error-not-all-same-type)))))) 95 | 'error-no-oper)))) 96 | 97 | (def new-generic (\ (name) 98 | (: (_table-add! name) 99 | (\ (.. x) (apply _apply-generic (_push name x)))))) 100 | 101 | (def implement (\ (name fn types) 102 | (_table-add-dispatch! name fn types))) 103 | 104 | (def + (new-generic '+)) 105 | (def - (new-generic '-)) 106 | (def * (new-generic '*)) 107 | (def < (new-generic '<)) 108 | (def > (new-generic '>)) 109 | (def <= (new-generic '<=)) 110 | (def >= (new-generic '>=)) 111 | (def % (new-generic '%)) 112 | (def first (new-generic 'first)) 113 | (def rest (new-generic 'rest)) 114 | (def print (new-generic 'print)) 115 | (implement '+ _+ 'integer) 116 | (implement '- _- 'integer) 117 | (implement '* _* 'integer) 118 | (implement '< _< '(integer integer)) 119 | (implement '> _> '(integer integer)) 120 | (implement '<= _<= '(integer integer)) 121 | (implement '>= _>= '(integer integer)) 122 | (implement '% _% '(integer integer)) 123 | (implement 'first _first '(list)) 124 | (implement 'rest _rest '(list)) 125 | (implement 'print _print '(list)) 126 | (implement 'print _print '(integer)) 127 | (implement 'print _print '(procedure)) 128 | (implement 'print _print '(symbol))) 129 | --------------------------------------------------------------------------------