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
|
||||
- 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
|
||||
|
@ -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,41 +304,48 @@
|
||||
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 ";")
|
||||
]
|
||||
(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 [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))
|
||||
(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 ";")) member-names))}
|
||||
"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) {
|
||||
"#include \"functions.h\"\n\nAPI STRUCT-NAME *CONSTRUCTOR-NAME(ARG_LIST) {
|
||||
STRUCT-NAME *new_struct = malloc(sizeof(STRUCT-NAME));
|
||||
SETTERS
|
||||
return new_struct;
|
||||
@ -349,7 +354,9 @@
|
||||
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)
|
||||
)))))
|
||||
(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/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))))))
|
||||
|
||||
|
@ -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
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;
|
||||
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);
|
||||
|
@ -768,15 +768,8 @@ 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]);
|
||||
}
|
||||
if(args[2]->tag != 'C') {
|
||||
eval_error = obj_new_string("'map2' requires arg 2 to be a list: ");
|
||||
obj_string_mut_append(eval_error, obj_to_string(args[2])->s);
|
||||
return nil;
|
||||
}
|
||||
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);
|
||||
@ -800,6 +793,31 @@ Obj *p_map2(Obj** args, int arg_count) {
|
||||
}
|
||||
shadow_stack_pop(); // list
|
||||
return 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 *p_keys(Obj** args, int arg_count) {
|
||||
|
Loading…
Reference in New Issue
Block a user