Skip to content
This repository was archived by the owner on Jan 2, 2023. It is now read-only.

Commit b9b7cb2

Browse files
borkdudeborkdude
authored
defn (#3)
1 parent 0091ac9 commit b9b7cb2

File tree

6 files changed

+218
-36
lines changed

6 files changed

+218
-36
lines changed

‎cherry/corpus/fns.cljs

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
(ns fns)
2+
3+
(def foo (fn foo [{:keys [a b]}]
4+
(+ a b)))
5+
6+
(prn (foo {:a 1 :b 2}))
7+
8+
(defn bar [{:keys [a b]}]
9+
(+ a b))
10+
11+
(prn (bar {:a 1 :b 2}))

‎cherry/corpus/fns.mjs

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,32 @@
1+
import { get, prn, __destructure_map, keyword, arrayMap } from 'cherry-cljs/cljs.core.js'
2+
3+
const foo = function foo (p__1201) {
4+
return (function () {
5+
return (function () {
6+
let map__1202, a, b;
7+
map__1202 = p__1201;
8+
map__1202 = __destructure_map(map__1202);
9+
a = get(map__1202, keyword("a"));
10+
b = get(map__1202, keyword("b"));
11+
return (function () {
12+
return (a + b);
13+
})();
14+
})();
15+
})();
16+
};
17+
prn(foo(arrayMap(keyword("a"), 1, keyword("b"), 2)));
18+
const bar = function (p__1204) {
19+
return (function () {
20+
return (function () {
21+
let map__1205, a, b;
22+
map__1205 = p__1204;
23+
map__1205 = __destructure_map(map__1205);
24+
a = get(map__1205, keyword("a"));
25+
b = get(map__1205, keyword("b"));
26+
return (function () {
27+
return (a + b);
28+
})();
29+
})();
30+
})();
31+
};
32+
prn(bar(arrayMap(keyword("a"), 1, keyword("b"), 2)));

‎cherry/corpus/no_core_vars.mjs

Lines changed: 2 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,6 @@
1-
import { js_keys, js_obj, prn } from 'cherry-cljs/cljs.core.js'
2-
31
function foo () {
42
return (function () {
5-
return js_obj("foo", "bar");
3+
return "hello";
64
})();
75
};
8-
prn(1);
9-
console.log(js_keys(foo()));
6+
console.log(foo());

‎cherry/src/cherry/internal/destructure.cljc

Lines changed: 0 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -112,23 +112,6 @@
112112
:cljs (new js/Error (str "Unsupported binding key: " (ffirst kwbs)))))
113113
(reduce process-entry [] bents)))))
114114

115-
(defn maybe-destructured
116-
[params body]
117-
(if (every? symbol? params)
118-
(cons params body)
119-
(loop [params params
120-
new-params (with-meta [] (meta params))
121-
lets []]
122-
(if params
123-
(if (symbol? (first params))
124-
(recur (next params) (conj new-params (first params)) lets)
125-
(let [gparam (gensym "p__")]
126-
(recur (next params) (conj new-params gparam)
127-
(-> lets (conj (first params)) (conj gparam)))))
128-
`(~new-params
129-
(let ~lets
130-
~@body))))))
131-
132115
(defn core-let
133116
[bindings body]
134117
#_(assert-args let

‎cherry/src/cherry/internal/fn.cljc

Lines changed: 146 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,146 @@
1+
(ns cherry.internal.fn)
2+
3+
#?(:cljs (def Exception js/Error))
4+
5+
(defn maybe-destructured
6+
[params body]
7+
(if (every? symbol? params)
8+
(cons params body)
9+
(loop [params params
10+
new-params (with-meta [] (meta params))
11+
lets []]
12+
(if params
13+
(if (symbol? (first params))
14+
(recur (next params) (conj new-params (first params)) lets)
15+
(let [gparam (gensym "p__")]
16+
(recur (next params) (conj new-params gparam)
17+
(-> lets (conj (first params)) (conj gparam)))))
18+
`(~new-params
19+
(let ~lets
20+
~@body))))))
21+
22+
(defn core-fn
23+
[&form sigs]
24+
(let [name (if (symbol? (first sigs)) (first sigs) nil)
25+
sigs (if name (next sigs) sigs)
26+
sigs (if (vector? (first sigs))
27+
(list sigs)
28+
(if (seq? (first sigs))
29+
sigs
30+
;; Assume single arity syntax
31+
(throw (Exception.
32+
(if (seq sigs)
33+
(str "Parameter declaration "
34+
(first sigs)
35+
" should be a vector")
36+
(str "Parameter declaration missing"))))))
37+
psig (fn* [sig]
38+
;; Ensure correct type before destructuring sig
39+
(when (not (seq? sig))
40+
(throw (Exception.
41+
(str "Invalid signature " sig
42+
" should be a list"))))
43+
(let [[params & body] sig
44+
_ (when (not (vector? params))
45+
(throw (Exception.
46+
(if (seq? (first sigs))
47+
(str "Parameter declaration " params
48+
" should be a vector")
49+
(str "Invalid signature " sig
50+
" should be a list")))))
51+
conds (when (and (next body) (map? (first body)))
52+
(first body))
53+
body (if conds (next body) body)
54+
conds (or conds (meta params))
55+
pre (:pre conds)
56+
post (:post conds)
57+
body (if post
58+
`((let [~'% ~(if (< 1 (count body))
59+
`(do ~@body)
60+
(first body))]
61+
~@(map (fn* [c] `(assert ~c)) post)
62+
~'%))
63+
body)
64+
body (if pre
65+
(concat (map (fn* [c] `(assert ~c)) pre)
66+
body)
67+
body)]
68+
(maybe-destructured params body)))
69+
new-sigs (map psig sigs)]
70+
(with-meta
71+
(if name
72+
(list* 'fn* name new-sigs)
73+
(cons 'fn* new-sigs))
74+
(meta &form))))
75+
76+
(defn
77+
^{:doc "Same as (def name (core/fn [params* ] exprs*)) or (def
78+
name (core/fn ([params* ] exprs*)+)) with any doc-string or attrs added
79+
to the var metadata. prepost-map defines a map with optional keys
80+
:pre and :post that contain collections of pre or post conditions."
81+
:arglists '([name doc-string? attr-map? [params*] prepost-map? body]
82+
[name doc-string? attr-map? ([params*] prepost-map? body)+ attr-map?])}
83+
core-defn [_&form _&env name fdecl]
84+
;; Note: Cannot delegate this check to def because of the call to (with-meta name ..)
85+
(if (instance? #?(:clj clojure.lang.Symbol :cljs Symbol) name)
86+
nil
87+
(throw
88+
#?(:clj (IllegalArgumentException. "First argument to defn must be a symbol")
89+
:cljs (js/Error. "First argument to defn must be a symbol"))))
90+
(let [m (if (string? (first fdecl))
91+
{:doc (first fdecl)}
92+
{})
93+
fdecl (if (string? (first fdecl))
94+
(next fdecl)
95+
fdecl)
96+
m (if (map? (first fdecl))
97+
(conj m (first fdecl))
98+
m)
99+
fdecl (if (map? (first fdecl))
100+
(next fdecl)
101+
fdecl)
102+
fdecl (if (vector? (first fdecl))
103+
(list fdecl)
104+
fdecl)
105+
m (if (map? (last fdecl))
106+
(conj m (last fdecl))
107+
m)
108+
fdecl (if (map? (last fdecl))
109+
(butlast fdecl)
110+
fdecl)
111+
m m #_(conj {:arglists (list 'quote (sigs fdecl))} m)
112+
;; no support for :inline
113+
;m (let [inline (:inline m)
114+
; ifn (first inline)
115+
; iname (second inline)]
116+
; ;; same as: (if (and (= 'fn ifn) (not (symbol? iname))) ...)
117+
; (if (if #?(:clj (clojure.lang.Util/equiv 'fn ifn)
118+
; :cljs (= 'fn ifn))
119+
; (if #?(:clj (instance? clojure.lang.Symbol iname)
120+
; :cljs (instance? Symbol iname)) false true))
121+
; ;; inserts the same fn name to the inline fn if it does not have one
122+
; (assoc m
123+
; :inline (cons ifn
124+
; (cons (clojure.lang.Symbol/intern
125+
; (.concat (.getName ^clojure.lang.Symbol name) "__inliner"))
126+
; (next inline))))
127+
; m))
128+
m (conj (if (meta name) (meta name) {}) m)]
129+
(cond
130+
#_(multi-arity-fn? fdecl)
131+
#_(multi-arity-fn name
132+
(if (comp/checking-types?)
133+
(update-in m [:jsdoc] conj "@param {...*} var_args")
134+
m) fdecl (:def-emits-var &env))
135+
136+
#_(variadic-fn? fdecl)
137+
#_(variadic-fn name
138+
(if (comp/checking-types?)
139+
(update-in m [:jsdoc] conj "@param {...*} var_args")
140+
m) fdecl (:def-emits-var &env))
141+
142+
:else
143+
(list 'def (with-meta name m)
144+
;;todo - restore propagation of fn name
145+
;;must figure out how to convey primitive hints to self calls first
146+
(cons `fn fdecl)))))

‎cherry/src/cherry/transpiler.clj

Lines changed: 27 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@
2929
cherry.transpiler
3030
(:require
3131
[cherry.internal.destructure :refer [core-let]]
32+
[cherry.internal.fn :refer [core-defn core-fn]]
3233
[clojure.edn :as edn]
3334
[clojure.java.io :as io]
3435
[clojure.string :as str]
@@ -96,7 +97,7 @@
9697
(defmethod emit :default [expr]
9798
(str expr))
9899

99-
(def special-forms (set ['var '. '.. 'if 'funcall 'fn 'quote 'set!
100+
(def special-forms (set ['var '. '.. 'if 'funcall 'fn 'fn* 'quote 'set!
100101
'return 'delete 'new 'do 'aget 'while 'doseq
101102
'inc! 'dec! 'dec 'inc 'defined? 'and 'or
102103
'? 'try 'break
@@ -321,24 +322,31 @@
321322
"\n }"))
322323

323324
(defn emit-var-declarations []
324-
(when-not (empty? @var-declarations)
325+
#_(when-not (empty? @var-declarations)
325326
(apply str "var "
326327
(str/join ", " (map emit @var-declarations))
327328
statement-separator)))
328329

330+
(declare emit-function*)
331+
329332
(defn emit-function [name sig body & [elide-function? async?]]
330-
(assert (or (symbol? name) (nil? name)))
331-
(assert (vector? sig))
332-
(let [body (return (emit-do body {:async? async?}))]
333-
(str (when-not elide-function? "function ") (comma-list sig) " {\n"
334-
(emit-var-declarations) body "\n}")))
333+
(do (assert (or (symbol? name) (nil? name)))
334+
(assert (vector? sig))
335+
(let [body (return (emit-do body {:async? async?}))]
336+
(str (when-not elide-function? "function ") (comma-list sig) " {\n"
337+
#_(emit-var-declarations) body "\n}"))))
335338

336339
(defn emit-function* [expr]
337340
(let [name (when (symbol? (first expr)) (first expr))
338-
async? (:async (meta name))]
341+
expr (if name (rest expr) expr)
342+
async? (:async (meta name))
343+
expr (if (seq? (first expr))
344+
;; TODO: multi-arity:
345+
(first expr)
346+
expr)]
339347
(if name
340-
(let [signature (second expr)
341-
body (rest (rest expr))]
348+
(let [signature (first expr)
349+
body (rest expr)]
342350
(str (when async?
343351
"async ") "function " name " "
344352
(binding [*async* async?]
@@ -347,11 +355,16 @@
347355
body (rest expr)]
348356
(str (emit-function nil signature body))))))
349357

350-
(defmethod emit-special 'fn [type [fn & expr]]
351-
(emit-function* expr ))
358+
(defmethod emit-special 'fn* [type [fn & sigs]]
359+
(emit-function* sigs))
360+
361+
(defmethod emit-special 'fn [type [fn & sigs :as expr]]
362+
(let [expanded (core-fn expr sigs)]
363+
(emit expanded)))
352364

353-
(defmethod emit-special 'defn [type [fn & expr]]
354-
(emit-function* expr))
365+
(defmethod emit-special 'defn [type [fn name & args :as expr]]
366+
(let [expanded (core-defn expr {} name args)]
367+
(emit expanded)))
355368

356369
(defmethod emit-special 'try [type [try & body :as expression]]
357370
(let [try-body (remove #(contains? #{'catch 'finally} (first %))

0 commit comments

Comments
 (0)