carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-10-12 04:58:18 +03:00
Code Issues Projects Releases Wiki Activity

struct constructor + lenses are automatically generated when defining the struct

Browse Source
This commit is contained in:
Erik 2016-03-04 15:58:48 +01:00
parent 88db88775d
commit 569bfc2651
7 changed files with 151 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
TODO.md
View File

@ -37,6 +37,7 @@
# Dynamic Runtime
- Should be error when ptr of wrong type is sent to baked function
- Binding to a function call in 'let' crashes process!!!
- Valgrind finds error with strdup in eval.c:312 ('apply' function)
- Valgrind finds error with realloc in obj_string.c line 17

77
lisp/builder.carp
View File

@ -211,8 +211,6 @@
arg-vars (map :c arg-results)
t (:type form)]
(do
(when (= true (get-maybe head :constructor))
(build-constructor-from-ast form))
(if (= :void t)
(do (str-append! c (str (indent) c-func-name "(" (join ", " arg-vars) ");\n"))
{:c n})
@ -306,50 +304,59 @@
x (error (str "Can't match :ast '" x "' in builder-visit-ast."))))
(defn build-constructor-from-ast [app-ast]
(let [;;_ (println (str app-ast))
constructor-ast (:head app-ast)
_ (assert-eq true (:constructor constructor-ast))
member-names (array-to-list (:member-names constructor-ast))
member-types (array-to-list (:member-types constructor-ast))
struct-name (:struct-name constructor-ast)]
(build-constructor struct-name member-names member-types)))
;; TODO: remove this function since we will bake the constructor when the type is defined instead?
;; (defn build-constructor-from-ast [app-ast]
;; (let [;;_ (println (str app-ast))
;; constructor-ast (:head app-ast)
;; _ (assert-eq true (:constructor constructor-ast))
;; member-names (array-to-list (:member-names constructor-ast))
;; member-types (array-to-list (:member-types constructor-ast))
;; struct-name (:struct-name constructor-ast)]
;; (build-constructor struct-name member-names member-types)))
;; This should potentially be done in a separate pass but right now I put it here.
;; What's needed when generating the code for structs is all the types used when
;; calling the constructor. Trying to do it in the 'generics' pass is hard since
;; we have too little information there.
(defn build-constructor [struct-name member-names member-types]
(let [constructor-name (str "new-" struct-name)
(let [member-names (if (array? member-names) (array-to-list member-names) member-names)
c-member-names (map c-ify-name member-names)
member-types (if (array? member-types) (array-to-list member-types) member-types)
constructor-name (str "new-" struct-name)
c-constructor-name (c-ify-name constructor-name)
c-file-name (str out-dir constructor-name ".c")
constructor-signature (list :fn member-types (keyword constructor-name))
constructor-signature (list :fn member-types (keyword struct-name))
;;_ (println (str constructor-signature))
type-def-c (join " " (map2 (fn [t n] (str (type-build t) " " n ";")) member-types c-member-names))
type-definition (str "typedef struct { " type-def-c " } " struct-name ";")
]
(if (func-baked? constructor-name)
(do
;;(println (str "Ignoring already baked constructor '" constructor-name "'"))
nil)
(let [type-def-c (join " " (map2 (fn [t n] (str (type-build t) " " n ";")) member-types member-names))
type-definition (str "typedef struct { " type-def-c " } " struct-name ";")
arg-list-c (join ", " (map2 (fn [t n] (str (type-build t) " " n)) member-types member-names))
proto (str struct-name " *" c-constructor-name "(" arg-list-c ");")
substs {"STRUCT-NAME" struct-name
"CONSTRUCTOR-NAME" c-constructor-name
"ARG_LIST" arg-list-c
"SETTERS" (join "\n " (map (fn [n] (str "new_struct->" n " = " n ";")) member-names))}
c-program-string (template
"#include \"functions.h\"\n\nAPI STRUCT-NAME *CONSTRUCTOR-NAME(ARG_LIST) {
(do
(add-type! struct-name type-definition)
;;(println (str "types:\n" types))
(save-function-prototypes)
(if (func-baked? constructor-name)
(do
;;(println (str "Ignoring already baked constructor '" constructor-name "'"))
nil)
(let [arg-list-c (join ", " (map2 (fn [t n] (str (type-build t) " " n)) member-types c-member-names))
proto (str struct-name " *" c-constructor-name "(" arg-list-c ");")
substs {"STRUCT-NAME" struct-name
"CONSTRUCTOR-NAME" c-constructor-name
"ARG_LIST" arg-list-c
"SETTERS" (join "\n " (map (fn [n] (str "new_struct->" n " = " n ";")) c-member-names))}
c-program-string (template
"#include \"functions.h\"\n\nAPI STRUCT-NAME *CONSTRUCTOR-NAME(ARG_LIST) {
STRUCT-NAME *new_struct = malloc(sizeof(STRUCT-NAME));
SETTERS
return new_struct;
}"
substs)
deps '()
]
(do
(add-type! constructor-name type-definition)
(def c c-program-string)
(save-and-compile constructor-name constructor-signature c-constructor-name c-file-name c-program-string proto deps false)
)))))
substs)
deps '()
]
(do
(def c c-program-string)
(save-and-compile constructor-name constructor-signature c-constructor-name c-file-name c-program-string proto deps false)
(map2 (fn [mem-name mem-type] (generate-struct-lens struct-name mem-name mem-type))
member-names
member-types)
))))))

3
lisp/compiler.carp
View File

@ -20,6 +20,7 @@
(load-lisp (str carp-dir "lisp/builder.carp"))
(load-lisp (str carp-dir "lisp/func_deps.carp"))
(load-lisp (str carp-dir "lisp/generics.carp"))
(load-lisp (str carp-dir "lisp/structs.carp"))
(def platform-specifics
(if (windows?)
@ -121,7 +122,7 @@
(str
"#include <shared.h>\n"
"//Types:\n"
(join "\n" (map :type-definition (values types)))
(join "\n" (map :type-definition (reverse (values types))))
"\n\n//Functions:\n"
(join "\n" (map :func-proto (values baked-funcs))))))

2
lisp/generics.carp
View File

@ -254,7 +254,7 @@
proto (str "string " c-func-name "(" t-name " *x)")
member-names (array-to-list (:member-names lookup))
member-types (array-to-list (:member-types lookup))
_ (build-constructor t-name member-names member-types) ;; build the constructor type to make it accessible to this function
;;_ (build-constructor t-name member-names member-types) ;; build the constructor type to make it accessible to this function
c (str proto " { "
" char buffer[1024];\n"
" int pos = 0;\n"

33
lisp/structs.carp Normal file
View File

@ -0,0 +1,33 @@
(defn generate-struct-lens [struct-name member-name member-type]
(do (println (str "Generating lens for '" struct-name "'-member '" member-name "' of type " member-type ))
(let [struct-type (keyword struct-name)
struct-t (type-build struct-type)
member-t (type-build member-type)
c-member-name (c-ify-name member-name)]
(do
(let [getter-signature (list :fn (list struct-type) member-type)
getter-proto (str member-t " get_" (c-ify-name member-name) "(" struct-t " x)")
getter-c (str getter-proto "{ return x->" c-member-name "; }")]
(bake-struct-lens-function (new-builder) (str "get-" member-name) getter-signature getter-proto getter-c '()))))))
(defn bake-struct-lens-function [builder func-name func-signature proto c deps]
(let [c-func-name (c-ify-name func-name)
c-file-name (str out-dir c-func-name ".c")]
(if (func-baked? func-name)
(do
(println (str "Ignoring already baked struct lens: " func-name))
nil)
(do
(println (str "Baking struct lens: " func-name " / " c-func-name " with signature " func-signature))
(let [c-program-string (str "#include <shared.h>\n#include \"functions.h\"\n" c)]
(do
(def c c-program-string)
(save-and-compile func-name
func-signature
c-func-name
c-file-name
c-program-string
(str proto ";")
deps
false)))))))

37
src/eval.c
View File

@ -729,8 +729,8 @@ void eval_list(Obj *env, Obj *o) {
int offset = 0;
bool generic = false;
for(int i = 0; i < member_count; i++) {
Obj *member_name = types->array[i * 2];
assert_or_set_error(member_name->tag == 'Y', "Struct member name must be symbol: ", member_name);
assert_or_set_error(types->array[i * 2]->tag == 'Y', "Struct member name must be symbol: ", types->array[i * 2]);
Obj *member_name = obj_new_string(types->array[i * 2]->s);
Obj *member_type = types->array[i * 2 + 1];
member_types->array[i] = member_type;
member_names->array[i] = member_name;
@ -741,17 +741,17 @@ void eval_list(Obj *env, Obj *o) {
else if(obj_eq(member_type, type_char)) { size = sizeof(char); }
else { size = sizeof(void*); }
char fixed_member_name[256];
snprintf(fixed_member_name, 255, "get-%s", member_name->s);
/* char fixed_member_name[256]; */
/* snprintf(fixed_member_name, 255, "get-%s", member_name->s); */
Obj *struct_member_lookup = obj_new_environment(NULL);
env_extend(struct_member_lookup, obj_new_keyword("struct-lookup"), lisp_true);
env_extend(struct_member_lookup, obj_new_keyword("struct-ref"), struct_description); // immediate access to the struct description
env_extend(struct_member_lookup, obj_new_keyword("member-offset"), obj_new_int(offset));
env_extend(struct_member_lookup, obj_new_keyword("member-name"), member_name);
env_extend(struct_member_lookup, obj_new_keyword("member-type"), member_type);
/* Obj *struct_member_lookup = obj_new_environment(NULL); */
/* env_extend(struct_member_lookup, obj_new_keyword("struct-lookup"), lisp_true); */
/* env_extend(struct_member_lookup, obj_new_keyword("struct-ref"), struct_description); // immediate access to the struct description */
/* env_extend(struct_member_lookup, obj_new_keyword("member-offset"), obj_new_int(offset)); */
/* env_extend(struct_member_lookup, obj_new_keyword("member-name"), member_name); */
/* env_extend(struct_member_lookup, obj_new_keyword("member-type"), member_type); */
env_extend(env, obj_new_symbol(fixed_member_name), struct_member_lookup);
/* env_extend(env, obj_new_symbol(fixed_member_name), struct_member_lookup); */
offset += size;
}
@ -765,8 +765,21 @@ void eval_list(Obj *env, Obj *o) {
env_extend(struct_description, obj_new_keyword("struct"), lisp_true);
env_extend(env, obj_new_symbol(name), struct_description);
stack_push(struct_description);
// Will call this function now: (build-constructor struct-name member-names member-types)
Obj *call_to_build_constructor = obj_list(obj_new_symbol("build-constructor"), obj_new_string(name), member_names, member_types);
shadow_stack_push(call_to_build_constructor);
//printf("Call to build-constructor: \n%s\n", obj_to_string(call_to_build_constructor)->s);
eval_internal(global_env, call_to_build_constructor);
shadow_stack_pop();
if(eval_error) {
printf("Error when calling build-constructor:\n");
printf("%s\n", obj_to_string(eval_error)->s);
return;
}
}
else if(HEAD_EQ("match")) {
eval_internal(env, o->cdr->car);

76
src/primops.c
View File

@ -768,38 +768,56 @@ Obj *p_map2(Obj** args, int arg_count) {
if(!is_callable(args[0])) {
set_error_return_nil("'map2' requires arg 0 to be a function or lambda: ", args[0]);
}
if(args[1]->tag != 'C') {
set_error_return_nil("'map2' requires arg 1 to be a list: ", args[1]);
Obj *f = args[0];
if(args[1]->tag == 'C' && args[2]->tag == 'C') {
Obj *p = args[1];
Obj *p2 = args[2];
Obj *list = obj_new_cons(NULL, NULL);
shadow_stack_push(list);
Obj *prev = list;
int shadow_count = 0;
while(p && p->car && p2 && p2->car) {
Obj *argz[2] = { p->car, p2->car };
apply(f, argz, 2);
prev->car = stack_pop();
Obj *new = obj_new_cons(NULL, NULL);
shadow_stack_push(new);
shadow_count++;
prev->cdr = new;
prev = new;
p = p->cdr;
p2 = p2->cdr;
}
for(int i = 0; i < shadow_count; i++) {
shadow_stack_pop();
}
shadow_stack_pop(); // list
return list;
}
if(args[2]->tag != 'C') {
eval_error = obj_new_string("'map2' requires arg 2 to be a list: ");
else if(args[1]->tag == 'A' && args[2]->tag == 'A') {
if(args[1]->count != args[2]->count) {
eval_error = obj_new_string("Arrays to map2 are of different length.");
return nil;
}
Obj *a = args[1];
Obj *b = args[2];
Obj *new_a = obj_new_array(a->count);
shadow_stack_push(new_a);
for(int i = 0; i < a->count; i++) {
Obj *fargs[2] = { a->array[i], b->array[i] };
apply(f, fargs, 2);
new_a->array[i] = stack_pop();
}
shadow_stack_pop(); // new_a
return new_a;
}
else {
eval_error = obj_new_string("'map2' requires both arg 1 and 2 to be lists or arrays:\n");
obj_string_mut_append(eval_error, obj_to_string(args[1])->s);
obj_string_mut_append(eval_error, "\n");
obj_string_mut_append(eval_error, obj_to_string(args[2])->s);
return nil;
}
Obj *f = args[0];
Obj *p = args[1];
Obj *p2 = args[2];
Obj *list = obj_new_cons(NULL, NULL);
shadow_stack_push(list);
Obj *prev = list;
int shadow_count = 0;
while(p && p->car && p2 && p2->car) {
Obj *argz[2] = { p->car, p2->car };
apply(f, argz, 2);
prev->car = stack_pop();
Obj *new = obj_new_cons(NULL, NULL);
shadow_stack_push(new);
shadow_count++;
prev->cdr = new;
prev = new;
p = p->cdr;
p2 = p2->cdr;
}
for(int i = 0; i < shadow_count; i++) {
shadow_stack_pop();
}
shadow_stack_pop(); // list
return list;
}
}
Obj *p_keys(Obj** args, int arg_count) {