mirror of
https://github.com/carp-lang/Carp.git
synced 2024-10-12 13:09:05 +03:00
struct constructor + lenses are automatically generated when defining the struct
This commit is contained in:
parent
88db88775d
commit
569bfc2651
1
TODO.md
1
TODO.md
@ -37,6 +37,7 @@
|
|||||||
|
|
||||||
|
|
||||||
# Dynamic Runtime
|
# Dynamic Runtime
|
||||||
|
- Should be error when ptr of wrong type is sent to baked function
|
||||||
- Binding to a function call in 'let' crashes process!!!
|
- Binding to a function call in 'let' crashes process!!!
|
||||||
- Valgrind finds error with strdup in eval.c:312 ('apply' function)
|
- Valgrind finds error with strdup in eval.c:312 ('apply' function)
|
||||||
- Valgrind finds error with realloc in obj_string.c line 17
|
- Valgrind finds error with realloc in obj_string.c line 17
|
||||||
|
@ -211,8 +211,6 @@
|
|||||||
arg-vars (map :c arg-results)
|
arg-vars (map :c arg-results)
|
||||||
t (:type form)]
|
t (:type form)]
|
||||||
(do
|
(do
|
||||||
(when (= true (get-maybe head :constructor))
|
|
||||||
(build-constructor-from-ast form))
|
|
||||||
(if (= :void t)
|
(if (= :void t)
|
||||||
(do (str-append! c (str (indent) c-func-name "(" (join ", " arg-vars) ");\n"))
|
(do (str-append! c (str (indent) c-func-name "(" (join ", " arg-vars) ");\n"))
|
||||||
{:c n})
|
{:c n})
|
||||||
@ -306,50 +304,59 @@
|
|||||||
x (error (str "Can't match :ast '" x "' in builder-visit-ast."))))
|
x (error (str "Can't match :ast '" x "' in builder-visit-ast."))))
|
||||||
|
|
||||||
|
|
||||||
|
;; TODO: remove this function since we will bake the constructor when the type is defined instead?
|
||||||
(defn build-constructor-from-ast [app-ast]
|
;; (defn build-constructor-from-ast [app-ast]
|
||||||
(let [;;_ (println (str app-ast))
|
;; (let [;;_ (println (str app-ast))
|
||||||
constructor-ast (:head app-ast)
|
;; constructor-ast (:head app-ast)
|
||||||
_ (assert-eq true (:constructor constructor-ast))
|
;; _ (assert-eq true (:constructor constructor-ast))
|
||||||
member-names (array-to-list (:member-names constructor-ast))
|
;; member-names (array-to-list (:member-names constructor-ast))
|
||||||
member-types (array-to-list (:member-types constructor-ast))
|
;; member-types (array-to-list (:member-types constructor-ast))
|
||||||
struct-name (:struct-name constructor-ast)]
|
;; struct-name (:struct-name constructor-ast)]
|
||||||
(build-constructor struct-name member-names member-types)))
|
;; (build-constructor struct-name member-names member-types)))
|
||||||
|
|
||||||
;; This should potentially be done in a separate pass but right now I put it here.
|
;; 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
|
;; 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
|
;; calling the constructor. Trying to do it in the 'generics' pass is hard since
|
||||||
;; we have too little information there.
|
;; we have too little information there.
|
||||||
(defn build-constructor [struct-name member-names member-types]
|
(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-constructor-name (c-ify-name constructor-name)
|
||||||
c-file-name (str out-dir constructor-name ".c")
|
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))
|
;;_ (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
|
||||||
(do
|
(add-type! struct-name type-definition)
|
||||||
;;(println (str "Ignoring already baked constructor '" constructor-name "'"))
|
;;(println (str "types:\n" types))
|
||||||
nil)
|
(save-function-prototypes)
|
||||||
(let [type-def-c (join " " (map2 (fn [t n] (str (type-build t) " " n ";")) member-types member-names))
|
(if (func-baked? constructor-name)
|
||||||
type-definition (str "typedef struct { " type-def-c " } " struct-name ";")
|
(do
|
||||||
arg-list-c (join ", " (map2 (fn [t n] (str (type-build t) " " n)) member-types member-names))
|
;;(println (str "Ignoring already baked constructor '" constructor-name "'"))
|
||||||
proto (str struct-name " *" c-constructor-name "(" arg-list-c ");")
|
nil)
|
||||||
substs {"STRUCT-NAME" struct-name
|
(let [arg-list-c (join ", " (map2 (fn [t n] (str (type-build t) " " n)) member-types c-member-names))
|
||||||
"CONSTRUCTOR-NAME" c-constructor-name
|
proto (str struct-name " *" c-constructor-name "(" arg-list-c ");")
|
||||||
"ARG_LIST" arg-list-c
|
substs {"STRUCT-NAME" struct-name
|
||||||
"SETTERS" (join "\n " (map (fn [n] (str "new_struct->" n " = " n ";")) member-names))}
|
"CONSTRUCTOR-NAME" c-constructor-name
|
||||||
c-program-string (template
|
"ARG_LIST" arg-list-c
|
||||||
"#include \"functions.h\"\n\nAPI STRUCT-NAME *CONSTRUCTOR-NAME(ARG_LIST) {
|
"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));
|
STRUCT-NAME *new_struct = malloc(sizeof(STRUCT-NAME));
|
||||||
SETTERS
|
SETTERS
|
||||||
return new_struct;
|
return new_struct;
|
||||||
}"
|
}"
|
||||||
substs)
|
substs)
|
||||||
deps '()
|
deps '()
|
||||||
]
|
]
|
||||||
(do
|
(do
|
||||||
(add-type! constructor-name type-definition)
|
(def c c-program-string)
|
||||||
(def c c-program-string)
|
(save-and-compile constructor-name constructor-signature c-constructor-name c-file-name c-program-string proto deps false)
|
||||||
(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)
|
||||||
|
))))))
|
||||||
|
@ -20,6 +20,7 @@
|
|||||||
(load-lisp (str carp-dir "lisp/builder.carp"))
|
(load-lisp (str carp-dir "lisp/builder.carp"))
|
||||||
(load-lisp (str carp-dir "lisp/func_deps.carp"))
|
(load-lisp (str carp-dir "lisp/func_deps.carp"))
|
||||||
(load-lisp (str carp-dir "lisp/generics.carp"))
|
(load-lisp (str carp-dir "lisp/generics.carp"))
|
||||||
|
(load-lisp (str carp-dir "lisp/structs.carp"))
|
||||||
|
|
||||||
(def platform-specifics
|
(def platform-specifics
|
||||||
(if (windows?)
|
(if (windows?)
|
||||||
@ -121,7 +122,7 @@
|
|||||||
(str
|
(str
|
||||||
"#include <shared.h>\n"
|
"#include <shared.h>\n"
|
||||||
"//Types:\n"
|
"//Types:\n"
|
||||||
(join "\n" (map :type-definition (values types)))
|
(join "\n" (map :type-definition (reverse (values types))))
|
||||||
"\n\n//Functions:\n"
|
"\n\n//Functions:\n"
|
||||||
(join "\n" (map :func-proto (values baked-funcs))))))
|
(join "\n" (map :func-proto (values baked-funcs))))))
|
||||||
|
|
||||||
|
@ -254,7 +254,7 @@
|
|||||||
proto (str "string " c-func-name "(" t-name " *x)")
|
proto (str "string " c-func-name "(" t-name " *x)")
|
||||||
member-names (array-to-list (:member-names lookup))
|
member-names (array-to-list (:member-names lookup))
|
||||||
member-types (array-to-list (:member-types 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 " { "
|
c (str proto " { "
|
||||||
" char buffer[1024];\n"
|
" char buffer[1024];\n"
|
||||||
" int pos = 0;\n"
|
" int pos = 0;\n"
|
||||||
|
33
lisp/structs.carp
Normal file
33
lisp/structs.carp
Normal 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
37
src/eval.c
@ -729,8 +729,8 @@ void eval_list(Obj *env, Obj *o) {
|
|||||||
int offset = 0;
|
int offset = 0;
|
||||||
bool generic = false;
|
bool generic = false;
|
||||||
for(int i = 0; i < member_count; i++) {
|
for(int i = 0; i < member_count; i++) {
|
||||||
Obj *member_name = types->array[i * 2];
|
assert_or_set_error(types->array[i * 2]->tag == 'Y', "Struct member name must be symbol: ", types->array[i * 2]);
|
||||||
assert_or_set_error(member_name->tag == 'Y', "Struct member name must be symbol: ", member_name);
|
Obj *member_name = obj_new_string(types->array[i * 2]->s);
|
||||||
Obj *member_type = types->array[i * 2 + 1];
|
Obj *member_type = types->array[i * 2 + 1];
|
||||||
member_types->array[i] = member_type;
|
member_types->array[i] = member_type;
|
||||||
member_names->array[i] = member_name;
|
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 if(obj_eq(member_type, type_char)) { size = sizeof(char); }
|
||||||
else { size = sizeof(void*); }
|
else { size = sizeof(void*); }
|
||||||
|
|
||||||
char fixed_member_name[256];
|
/* char fixed_member_name[256]; */
|
||||||
snprintf(fixed_member_name, 255, "get-%s", member_name->s);
|
/* snprintf(fixed_member_name, 255, "get-%s", member_name->s); */
|
||||||
|
|
||||||
Obj *struct_member_lookup = obj_new_environment(NULL);
|
/* 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-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("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-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-name"), member_name); */
|
||||||
env_extend(struct_member_lookup, obj_new_keyword("member-type"), member_type);
|
/* 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;
|
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(struct_description, obj_new_keyword("struct"), lisp_true);
|
||||||
|
|
||||||
env_extend(env, obj_new_symbol(name), struct_description);
|
env_extend(env, obj_new_symbol(name), struct_description);
|
||||||
|
|
||||||
stack_push(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")) {
|
else if(HEAD_EQ("match")) {
|
||||||
eval_internal(env, o->cdr->car);
|
eval_internal(env, o->cdr->car);
|
||||||
|
@ -768,38 +768,56 @@ Obj *p_map2(Obj** args, int arg_count) {
|
|||||||
if(!is_callable(args[0])) {
|
if(!is_callable(args[0])) {
|
||||||
set_error_return_nil("'map2' requires arg 0 to be a function or lambda: ", args[0]);
|
set_error_return_nil("'map2' requires arg 0 to be a function or lambda: ", args[0]);
|
||||||
}
|
}
|
||||||
if(args[1]->tag != 'C') {
|
Obj *f = args[0];
|
||||||
set_error_return_nil("'map2' requires arg 1 to be a list: ", args[1]);
|
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') {
|
else if(args[1]->tag == 'A' && args[2]->tag == 'A') {
|
||||||
eval_error = obj_new_string("'map2' requires arg 2 to be a list: ");
|
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);
|
obj_string_mut_append(eval_error, obj_to_string(args[2])->s);
|
||||||
return nil;
|
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) {
|
Obj *p_keys(Obj** args, int arg_count) {
|
||||||
|
Loading…
Reference in New Issue
Block a user