carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-10-11 20:49:05 +03:00
Code Issues Projects Releases Wiki Activity

fix and*, make macros print their name when given wrong arg count

Browse Source
This commit is contained in:
Erik Svedäng 2016-06-16 12:26:14 +02:00
parent defaa5eeb3
commit 6107e619d4
9 changed files with 54 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
examples/project.carp
View File

@ -23,32 +23,40 @@
;; (def inc (fn [x] (+ x 1)))
;; (def fib (fn [x]
;; (if (< x 2)
;; 1
;; (+ (fib (- x 2))
;; (fib (- x 1))))))
(def fib (fn [x]
(if (< x 2)
1
(+ (fib (- x 2))
(fib (- x 1))))))
;; (def g (fn [x] (* x x)))
;; (def h (fn [x] (+ (g x) (g x))))
(load-lisp "../lisp/core_macros.carp")
(def inc (fn [x] (+ x 1)))
(def make-counter (fn [start]
(let [value start]
(fn []
(do (reset! value (inc value))
value)))))
(def c1 (make-counter 10))
(def c2 (make-counter 10))
(println (str "c1: " (c1)))
(println (str "c1: " (c1)))
(println (str "c1: " (c1)))
(println (str "c2: " (c2)))
;; (load-lisp "../lisp/core_macros.carp")
;; (def inc (fn [x] (+ x 1)))
;; (def make-counter (fn [start]
;; (let [value start]
;; (fn []
;; (do (reset! value (inc value))
;; value)))))
;; (def c1 (make-counter 10))
;; (def c2 (make-counter 10))
;; (println (str "c1: " (c1)))
;; (println (str "c1: " (c1)))
;; (println (str "c1: " (c1)))
;; (println (str "c2: " (c2)))
;; (match 2 1 "a" 2 "b" 3 "c")
@ -84,25 +92,6 @@
;; (do
;; (assert-eq false (= d1 d2))))
(let [d1 {:x 10 :y 20}
d2 {:x 10}
d3 {:y 20 :x 10}]
(do
;; (assert-eq d1 d3)
;; (assert-eq false (= d1 d2))
(assert-eq false (= d1 {}))
(assert-eq d3 (assoc d2 :y 20))
(assert-eq true (= d1 (assoc d2 :y 20)))
))
(let [a 10]
(do
(assert-eq 10 10)
(assert-eq 20 20)
(assert-eq 30 (+ 10 20))
(assert-eq 20 (+ a a))))
;; (let [d1 (dictionary :x 10 :y 20)
;; d2 (dictionary :x 10)
;; d3 (dictionary :y 20 :x 10)]
@ -113,3 +102,4 @@
;; (assert-eq d3 (assoc d2 :y 20))
;; (assert-eq true (= d1 (assoc d2 :y 20)))
;; ))

8
lisp/ast.carp
View File

@ -51,7 +51,7 @@
(match l
(x ... xs) (if (def? x)
(let [evaled (eval x)]
(if (and (symbol? x) (macro? evaled))
(if (and* (symbol? x) (macro? evaled))
(expand-macro l)
(app-to-ast x xs l)))
(app-to-ast x xs l))
@ -140,7 +140,7 @@
(defn literal-or-lookup-to-ast [expr]
(if (symbol? expr)
(let [is-generic-lens-stub (and (def? expr) (is-generic-lens-stub? (eval (list 'meta expr))))
(let [is-generic-lens-stub (and* (def? expr) (is-generic-lens-stub? (eval (list 'meta expr))))
node {:node :lookup
:type (gen-typevar)
:generic-lens-stub is-generic-lens-stub
@ -174,7 +174,7 @@
(key-is-true? form :generic-lens-stub)))
(defn is-struct-constructor? [form]
(and (dict? form) (true? (get-maybe form :struct))))
(and* (dict? form) (true? (get-maybe form :struct))))
(defn struct-constructor-ast [struct-description]
(let [struct-name (:name struct-description)
@ -226,7 +226,7 @@
(list-to-ast x)
(if (array? x)
(array-to-ast x)
(if (and (symbol? x) (def? x) (is-struct-constructor? (eval x)))
(if (and* (symbol? x) (def? x) (is-struct-constructor? (eval x)))
(struct-constructor-ast (eval x))
(literal-or-lookup-to-ast x))))))

4
lisp/builder.carp
View File

@ -94,8 +94,8 @@
(map (fn (arg) {:c (:arg-name arg)}) args))))
(defn inlined-literal? [ast]
(and (= :literal (:node ast))
(contains? '(:int :float :double :bool (:ref :string)) (:type ast))))
(and* (= :literal (:node ast))
(contains? '(:int :float :double :bool (:ref :string)) (:type ast))))
(defn inlined-lookup? [ast]
(= :lookup (:node ast)))

4
lisp/calculate_lifetimes.carp
View File

@ -73,7 +73,7 @@
;;_ (println (str "\n " (:arg-name arg-ast) " vars:\n" vars "\n"))
new-data (if (and (= :literal (:node arg-ast)) (not is-ref))
new-data (if (and* (= :literal (:node arg-ast)) (not is-ref))
{:ast arg-ast :vars vars} ;; a literal as an arg to a non-ref parameter doesn't create any new vars to free
(calculate-lifetimes-internal {:ast arg-ast
:env env
@ -270,7 +270,7 @@
;;_ (println (str "derefed-var-name: " derefed-var-name))
given-away (= 0 (count (filter (fn (v) (= derefed-var-name (:name v))) vars)))]
(if (and (or is-ref-lookup (managed-type? t)) given-away)
(if (and* (or* is-ref-lookup (managed-type? t)) given-away)
(if (:global-lookup ast)
data
(error {:error error-given-away

8
lisp/concretize.carp
View File

@ -305,7 +305,7 @@
(primitive-type? maybe-struct-type))
(error (str "Primitive type sent to '=' instantiator for struct types, but it is not a struct type: " maybe-struct-type)))
lookup (eval (symbol (name maybe-struct-type)))]
(if (and (dict? lookup) (= true (get-maybe lookup :struct)))
(if (and* (dict? lookup) (= true (get-maybe lookup :struct)))
(let [t-name (name maybe-struct-type)
proto (str "API bool " c-func-name "(" t-name " *a, " t-name " *b)")
member-names (array-to-list (:member-names lookup))
@ -367,7 +367,7 @@
(primitive-type? maybe-struct-type))
(error (str "Primitive type sent to 'str' instantiator for struct types, but it is not a struct type: " maybe-struct-type)))
lookup (eval (symbol (name maybe-struct-type)))]
(if (and (dict? lookup) (= true (get-maybe lookup :struct)))
(if (and* (dict? lookup) (= true (get-maybe lookup :struct)))
(let [t-name (name maybe-struct-type)
proto (str "API string " c-func-name "(" (c-ify-name t-name) " *x)")
member-names (array-to-list (:member-names lookup))
@ -457,7 +457,7 @@
(primitive-type? maybe-struct-type))
(error (str "Primitive type sent to 'copy' instantiator for struct types, but it is not a struct type: " maybe-struct-type)))
lookup (eval (symbol (name maybe-struct-type)))]
(if (and (dict? lookup) (= true (get-maybe lookup :struct)))
(if (and* (dict? lookup) (= true (get-maybe lookup :struct)))
(let [t-name (name maybe-struct-type)
proto (str t-name " *" c-func-name "(" t-name " *x)")
;;_ (println (str "proto for struct copying function: " proto))
@ -530,7 +530,7 @@
(primitive-type? maybe-struct-type))
(error (str "Primitive type sent to 'delete' instantiator for struct types, but it is not a struct type: " maybe-struct-type)))
lookup (eval (symbol (name maybe-struct-type)))]
(if (and (dict? lookup) (= true (get-maybe lookup :struct)))
(if (and* (dict? lookup) (= true (get-maybe lookup :struct)))
(let [t-name (name maybe-struct-type)
proto (str "API void " c-func-name "(" t-name " *x)")
;;_ (println (str "proto for struct delete function: " proto))

4
lisp/func_deps.carp
View File

@ -48,12 +48,12 @@
(do
;;(println (str "Found constructor '" symbol-name "'"))
(reset! deps (cons symbol-name deps))))
(when (and is-lambda bake-deps (not is-generic-lens-stub)) ;; Bake, then add to deps
(when (and* is-lambda bake-deps (not is-generic-lens-stub)) ;; Bake, then add to deps
(do
;;(println (str symbol " is a dependency of " func-name ", code: " (code evaled)))
(compiler/bake-code symbol-name (code evaled) (meta-get evaled :ann))
(reset! deps (cons symbol-name deps))))
(when (and (foreign? evaled))
(when (foreign? evaled)
(reset! deps (cons symbol-name deps)))
)))
(assoc ast :global-lookup is-global-lookup))))

4
lisp/generics.carp
View File

@ -56,7 +56,7 @@
(do
;;(println (str (:value ast) " : " t))
;;(println (str "ast:\n" ast))
(if (and (nil? (get-maybe ast :self-recursive)) (:global-lookup ast))
(if (and* (nil? (get-maybe ast :self-recursive)) (:global-lookup ast))
(let [lookup-sym (:value ast)
;;_ (println (str "Will eval " ast))
global-lookup (eval lookup-sym)
@ -68,7 +68,7 @@
is-generic-lens-stub (key-is-true? ast :generic-lens-stub)
]
(if (and (lambda? global-lookup) is-generic)
(if (and* (lambda? global-lookup) is-generic)
(if (generic-type? t)
(do
;;(println (str "Lambda with missing type information, can't compile concrete version: " lookup-sym " of type " t))

2
src/bytecode.c
View File

@ -453,7 +453,7 @@ void bytecode_frame_print(Process *process, BytecodeFrame frame) {
void bytecode_stack_print(Process *process) {
printf("----------------------------------------------------------------\n");
for(int i = 0; i <= process->frame; i++) {
printf("%d ", i);
printf("%d\t", i);
bytecode_frame_print(process, process->frames[i]);
printf("\n");
}

11
src/env.c
View File

@ -4,6 +4,7 @@
#include "assertions.h"
Obj *env_lookup(Process *process, Obj *env, Obj *symbol) {
assert(env->tag == 'E');
Obj *p = env->bindings;
while(p && p->car) {
Obj *pair = p->car;
@ -118,7 +119,15 @@ void env_extend_with_args(Process *process, Obj *calling_env, Obj *function, int
if(arg_count > paramp->count) {
printf("arguments: %s\n", obj_to_string(process, paramp)->s);
set_error("Too many arguments (A) to function/macro: ", function);
//printf("meta: %s\n", (function->meta ? obj_to_string(process, function->meta)->s : "NULL"));
Obj *name = function;
if(function->meta) {
Obj *name_lookup = env_lookup(process, function->meta, obj_new_keyword("name"));
if(name_lookup) {
name = name_lookup;
}
}
set_error("Too many arguments (A) to function/macro: ", name);
}
}