mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
refactor: Move code out of Macros.carp into other files (#1014)
* refactor: Move code out of Macros.carp into other files * fix: Move back some macros needed in --no-core mode * refactor: Remove weird 'evaluate' macros * fix: Put back more macros * fix: Remove transitive loading of Macros.carp * refactor: Remove ArrayMacros.carp and put 'for' at top of Array.carp instead * refactor: More splitting up * refactor: Move back save-docs * fix: Moved back some stuff Co-authored-by: Erik Svedang <erik@Eriks-iMac.local>
This commit is contained in:
parent
8c07bda22a
commit
f78fd16a71
@ -1,3 +1,29 @@
|
||||
(defmacro for [settings :rest body] ;; settings = variable, from, to, <step>
|
||||
(if (> (length body) 1)
|
||||
(macro-error "Warning: the body of the 'for' loop can only contain one expression")
|
||||
(let [variable (car settings)
|
||||
from (cadr settings)
|
||||
to (caddr settings)
|
||||
step (if (> (length settings) 3) (cadddr settings) 1)
|
||||
comp (if (> (length settings) 4)
|
||||
(cadddr (cdr settings))
|
||||
(if (< step (- step step)) '> '<))
|
||||
]
|
||||
(list
|
||||
'let (array variable from)
|
||||
(list
|
||||
'while (list comp variable to)
|
||||
(list
|
||||
'do
|
||||
(if (= (length body) 0)
|
||||
()
|
||||
(if (list? body)
|
||||
(car body)
|
||||
body))
|
||||
(list
|
||||
'set! variable
|
||||
(list '+ variable step))))))))
|
||||
|
||||
(defmodule Array
|
||||
|
||||
(doc reduce "will reduce an array `xs` into a single value using a function `f` that takes the reduction thus far and the next value. The initial reduction value is `x`.
|
||||
@ -390,3 +416,22 @@ It will create a copy. If you want to avoid that, consider using [`endo-filter`]
|
||||
(for [i 0 (StaticArray.length sarr)]
|
||||
(aset-uninitialized! &darr i @(StaticArray.unsafe-nth sarr i)))
|
||||
darr)))
|
||||
|
||||
(defmacro doall [f xs]
|
||||
(list 'for ['i 0 (list 'Array.length (list 'ref xs))]
|
||||
(list f (list 'Array.unsafe-nth (list 'ref xs) 'i))))
|
||||
|
||||
(defndynamic foreach-internal [var xs expr]
|
||||
(let [xsym (gensym-with 'xs)
|
||||
len (gensym-with 'len)
|
||||
i (gensym-with 'i)]
|
||||
(list 'let [xsym xs
|
||||
len (list 'Array.length xsym)]
|
||||
(list 'for [i 0 len]
|
||||
(list 'let [var (list 'Array.unsafe-nth xsym i)]
|
||||
expr)))))
|
||||
|
||||
(defmacro foreach [binding expr]
|
||||
(if (array? binding)
|
||||
(foreach-internal (car binding) (cadr binding) expr)
|
||||
(macro-error "Binding has to be an array.")))
|
||||
|
223
core/ControlMacros.carp
Normal file
223
core/ControlMacros.carp
Normal file
@ -0,0 +1,223 @@
|
||||
(defndynamic thread-first-internal [xs]
|
||||
(if (= (length xs) 2)
|
||||
(if (list? (last xs))
|
||||
(cons (caadr xs)
|
||||
(cons (car xs)
|
||||
(cdadr xs)))
|
||||
(list (cadr xs) (car xs)))
|
||||
(if (list? (last xs))
|
||||
(append
|
||||
(list
|
||||
(car (last xs))
|
||||
(thread-first-internal (all-but-last xs)))
|
||||
(cdr (last xs)))
|
||||
(list (last xs) (thread-first-internal (all-but-last xs))))))
|
||||
|
||||
(defndynamic thread-last-internal [xs]
|
||||
(if (= (length xs) 2)
|
||||
(if (list? (last xs))
|
||||
(cons-last (car xs) (last xs))
|
||||
(list (cadr xs) (car xs)))
|
||||
(if (list? (last xs))
|
||||
(cons-last (thread-last-internal (all-but-last xs)) (last xs))
|
||||
(list (last xs) (thread-last-internal (all-but-last xs))))))
|
||||
|
||||
(defmacro => [:rest forms]
|
||||
(thread-first-internal forms))
|
||||
|
||||
(defmacro ==> [:rest forms]
|
||||
(thread-last-internal forms))
|
||||
|
||||
(defmacro -> [:rest forms]
|
||||
(thread-first-internal forms))
|
||||
|
||||
(defmacro --> [:rest forms]
|
||||
(thread-last-internal forms))
|
||||
|
||||
(defndynamic comp-internal [sym fns]
|
||||
(if (= (length fns) 0)
|
||||
sym
|
||||
(list (car fns) (comp-internal sym (cdr fns)))))
|
||||
|
||||
(doc comp "Composes the functions `fns` into one `fn`.")
|
||||
(defmacro comp [:rest fns]
|
||||
(let [x (gensym)]
|
||||
(list 'fn [x] (comp-internal x fns))))
|
||||
|
||||
(doc doto
|
||||
"Evaluates `thing`, then calls all of the functions on it and"
|
||||
"returns it. Useful for chaining mutating, imperative functions, and thus"
|
||||
"similar to `->`. If you need `thing` to be passed as a `ref` into `expressions`"
|
||||
"functions, use [`doto-ref`](#doto-ref) instead."
|
||||
""
|
||||
"```"
|
||||
"(let [x @\"hi\"]"
|
||||
" @(doto &x"
|
||||
" (string-set! 0 \o)"
|
||||
" (string-set! 1 \y)))"
|
||||
"```")
|
||||
(defmacro doto [thing :rest expressions]
|
||||
(let [s (gensym)]
|
||||
(list 'let [s thing]
|
||||
(cons-last
|
||||
s
|
||||
(cons 'do (map (fn [expr] (cons (car expr) (cons s (cdr expr)))) expressions))))))
|
||||
|
||||
(doc doto-ref
|
||||
"Evaluates `thing`, then calls all of the functions on it and"
|
||||
"returns it. Useful for chaining mutating, imperative functions, and thus"
|
||||
"similar to `->`. If you need `thing` not to be passed as a `ref` into"
|
||||
"`expressions` functions, use [`doto`](#doto) instead."
|
||||
""
|
||||
"```"
|
||||
"(doto-ref @\"hi\""
|
||||
" (string-set! 0 \o)"
|
||||
" (string-set! 1 \y))"
|
||||
"```")
|
||||
(defmacro doto-ref [thing :rest expressions]
|
||||
(let [s (gensym)]
|
||||
(list 'let [s thing]
|
||||
(cons-last
|
||||
s
|
||||
(cons 'do
|
||||
(map (fn [expr] (cons (car expr) (cons (list 'ref s) (cdr expr))))
|
||||
expressions))))))
|
||||
|
||||
(doc until "Executes `body` until the condition `cnd` is true.")
|
||||
(defmacro until [cnd body]
|
||||
(list 'while (list 'not cnd)
|
||||
body))
|
||||
|
||||
(defmacro let-do [bindings :rest forms]
|
||||
(list 'let bindings
|
||||
(cons 'do forms)))
|
||||
|
||||
(defmacro while-do [condition :rest forms]
|
||||
(list 'while condition
|
||||
(cons 'do forms)))
|
||||
|
||||
(defmacro defn-do [name arguments :rest body]
|
||||
(eval (list 'defn name arguments (cons 'do body))))
|
||||
|
||||
(defmacro forever-do [:rest forms]
|
||||
(list 'while true (cons 'do forms)))
|
||||
|
||||
(defmacro when [condition form]
|
||||
(list 'if condition form (list)))
|
||||
|
||||
(defmacro unless [condition form]
|
||||
(list 'if condition (list) form))
|
||||
|
||||
(defndynamic case-internal [name xs]
|
||||
(if (= (length xs) 0)
|
||||
(list)
|
||||
(if (= (length xs) 2)
|
||||
(macro-error "case has even number of branches; add an else branch")
|
||||
(if (= (length xs) 1)
|
||||
(car xs)
|
||||
(list 'if
|
||||
(list '= name (car xs))
|
||||
(cadr xs)
|
||||
(case-internal name (cddr xs)))))))
|
||||
|
||||
(defmacro case [name :rest forms]
|
||||
(case-internal name forms))
|
||||
|
||||
(defmodule Dynamic
|
||||
(doc flip
|
||||
"Flips the arguments of a function `f`."
|
||||
"```"
|
||||
"((flip Symbol.prefix) 'Bar 'Foo)"
|
||||
"=> (Foo.Bar)"
|
||||
"```")
|
||||
(defndynamic flip [f]
|
||||
(fn [x y]
|
||||
(f y x)))
|
||||
|
||||
;; Higher-order functions can't currently accept primitives
|
||||
;; For now, wrapping primitives in a function allows us to pass them
|
||||
;; to HOFs like map.
|
||||
|
||||
(doc compose
|
||||
"Returns the composition of two functions `f` and `g` for functions of any"
|
||||
"arity; concretely, returns a function accepting the correct number of"
|
||||
"arguments for `g`, applies `g` to those arguments, then applies `f` to the"
|
||||
"result."
|
||||
""
|
||||
"If you only need to compose functions that take a single argument (unary arity)"
|
||||
"see `comp`. Comp also generates the form that corresponds to the composition,"
|
||||
"compose contrarily evaluates 'eagerly' and returns a computed symbol."
|
||||
"```"
|
||||
";; a silly composition"
|
||||
"((compose empty take) 3 [1 2 3 4 5])"
|
||||
";; => []"
|
||||
""
|
||||
"(String.join (collect-into ((compose reverse map) Symbol.str '(p r a c)) array))"
|
||||
";; => 'carp'"
|
||||
""
|
||||
";; comp for comparison"
|
||||
"((comp (curry + 1) (curry + 2)) 4)"
|
||||
";; => (+ 1 (+ 2 4))"
|
||||
"```")
|
||||
(defndynamic compose [f g]
|
||||
;; Recall that **unquoted** function names evaluate to their definitions in
|
||||
;; dynamic contexts, e.g. f = (dyanmic f [arg] body)
|
||||
;;
|
||||
;; Right now, this cannot handle anonymous functions because they cannot be passed to apply.
|
||||
;; and not anonymous functions.
|
||||
;; commands expand to (command <name>), fns expand to a non-list.
|
||||
;;
|
||||
;; TODO: Support passing anonymous functions.
|
||||
(if (not (or (list? f) (list? g)))
|
||||
(macro-error "compose can only compose named dynamic functions. To
|
||||
compose anonymous functions, such as curried functions,
|
||||
see comp.")
|
||||
(let [f-name (cadr f)
|
||||
g-name (cadr g)
|
||||
arguments (caddr g)]
|
||||
(list 'fn arguments
|
||||
;; Since we call an eval to apply g immediately, we wrap the args in an
|
||||
;; extra quote, otherwise, users would need to double quote any sequence of
|
||||
;; symbols such as '(p r a c)
|
||||
(list f-name (list 'eval (list 'apply g-name (list 'quote arguments))))))))
|
||||
|
||||
(doc curry
|
||||
"Returns a curried function accepting a single argument, that applies `f` to `x`"
|
||||
"and then to the following argument."
|
||||
""
|
||||
"```"
|
||||
"(map (curry Symbol.prefix 'Foo) '(bar baz))"
|
||||
"=> (Foo.bar Foo.baz)"
|
||||
"```")
|
||||
(defndynamic curry [f x]
|
||||
(fn [y]
|
||||
(f x y)))
|
||||
|
||||
(doc curry*
|
||||
"Curry functions of any arity."
|
||||
""
|
||||
"```"
|
||||
"(map (curry* Dynamic.zip + '(1 2 3)) '((4 5) (6)))"
|
||||
"=> (((+ 1 4) (+ 2 5)) ((+ 1 6)))"
|
||||
""
|
||||
"((curry* Dynamic.zip cons '(1 2 3)) '((4 5) (6)))"
|
||||
"=> ((cons 1 (4 5)) (cons (2 (6))))"
|
||||
""
|
||||
"(defndynamic add-em-up [x y z] (+ (+ x y) z))"
|
||||
"(map (curry* add-em-up 1 2) '(1 2 3))"
|
||||
"=> (4 5 6)"
|
||||
"```")
|
||||
(defndynamic curry* [f :rest args]
|
||||
(let [f-name (cadr f)
|
||||
all-args (caddr f)
|
||||
unfilled-args (- (length all-args) (length args))
|
||||
remaining (take unfilled-args all-args)
|
||||
;; Quote the arguments to retain expected behavior and avoid the need
|
||||
;; for double quotes in curried higher-orders, e.g. zip.
|
||||
quote-args (map quoted args)]
|
||||
(list 'fn remaining
|
||||
;; eval to execute the curried function.
|
||||
;; otherwise, this resolves to the form that will call the function, e.g. (add-three-vals 2 3 1)
|
||||
(list 'eval (list 'apply f-name (list 'quote (append quote-args (collect-into
|
||||
remaining list))))))))
|
||||
)
|
@ -18,6 +18,11 @@
|
||||
(load-once "Interfaces.carp")
|
||||
(load-once "Bool.carp")
|
||||
(load-once "Macros.carp")
|
||||
(load-once "List.carp")
|
||||
(load-once "Gensym.carp")
|
||||
(load-once "ControlMacros.carp")
|
||||
(load-once "Project.carp")
|
||||
(load-once "Platform.carp")
|
||||
(load-once "Introspect.carp")
|
||||
(load-once "Pointer.carp")
|
||||
(load-once "Unsafe.carp")
|
||||
@ -33,8 +38,8 @@
|
||||
(load-once "Double.carp")
|
||||
(load-once "Float.carp")
|
||||
(load-once "Tuples.carp")
|
||||
(load-once "StaticArray.carp")
|
||||
(load-once "Array.carp")
|
||||
(load-once "StaticArray.carp")
|
||||
(load-once "StdInt.carp")
|
||||
(load-once "Char.carp")
|
||||
(load-once "String.carp")
|
||||
|
15
core/Gensym.carp
Normal file
15
core/Gensym.carp
Normal file
@ -0,0 +1,15 @@
|
||||
(doc *gensym-counter* "Is a helper counter for `gensym`.")
|
||||
(defdynamic *gensym-counter* 1000)
|
||||
|
||||
(defndynamic gensym-local [x]
|
||||
(Symbol.concat ['gensym-generated x]))
|
||||
|
||||
(doc gensym-with "Generates symbols dynamically, based on a symbol name.")
|
||||
(defndynamic gensym-with [x]
|
||||
(do
|
||||
(set! *gensym-counter* (inc *gensym-counter*))
|
||||
(Symbol.concat [x (Symbol.from *gensym-counter*)])))
|
||||
|
||||
(doc gensym "Generates symbols dynamically as needed.")
|
||||
(defndynamic gensym []
|
||||
(gensym-with 'gensym-generated))
|
@ -81,3 +81,9 @@
|
||||
(Maybe.Nothing)
|
||||
(Maybe.Just (from-cstr e)))))
|
||||
)
|
||||
|
||||
(defmacro println* [:rest forms]
|
||||
(list 'IO.println (build-str* forms)))
|
||||
|
||||
(defmacro print* [:rest forms]
|
||||
(list 'IO.print (build-str* forms)))
|
@ -1,5 +1,3 @@
|
||||
(load-once "Macros.carp")
|
||||
|
||||
;; The 'copy' and 'str' interfaces are defined internally:
|
||||
;;(definterface copy (λ [&a] a))
|
||||
;;(definterface str (λ [a] String))
|
||||
|
@ -34,24 +34,24 @@
|
||||
false
|
||||
(Dynamic.= (Symbol.from "primitive") (car s)))))
|
||||
|
||||
(doc external?
|
||||
"Is this binding external?")
|
||||
(doc external?
|
||||
"Is this binding external?")
|
||||
(defndynamic external? [binding]
|
||||
(let [s (s-expr binding)]
|
||||
(if (empty? s)
|
||||
false
|
||||
(Dynamic.= (Symbol.from "external") (car s)))))
|
||||
false
|
||||
(Dynamic.= (Symbol.from "external") (car s)))))
|
||||
|
||||
(doc variable?
|
||||
"Is this binding a variable?")
|
||||
"Is this binding a variable?")
|
||||
(defndynamic variable? [binding]
|
||||
(let [s (s-expr binding)]
|
||||
(if (empty? s)
|
||||
false
|
||||
(Dynamic.= (Symbol.from "def") (car s)))))
|
||||
false
|
||||
(Dynamic.= (Symbol.from "def") (car s)))))
|
||||
|
||||
(doc type?
|
||||
"Is this binding a type?")
|
||||
"Is this binding a type?")
|
||||
(defndynamic type? [binding]
|
||||
(let [s (s-expr binding)]
|
||||
(if (empty? s)
|
||||
@ -74,6 +74,12 @@
|
||||
false
|
||||
(list? (caddr s)))))
|
||||
|
||||
(doc implements? "Does `function` implement `interface`?")
|
||||
(defmacro implements? [interface function]
|
||||
(eval (list 'any?
|
||||
(list 'fn (array 'x) (list '= 'x interface))
|
||||
(list 'meta function "implements"))))
|
||||
|
||||
(doc arity
|
||||
"What's the arity of this binding?
|
||||
|
||||
|
241
core/List.carp
Normal file
241
core/List.carp
Normal file
@ -0,0 +1,241 @@
|
||||
(defmodule Dynamic
|
||||
|
||||
(defndynamic cxr [x pair]
|
||||
(if (= (length x) 0)
|
||||
(list 'quote pair)
|
||||
(list
|
||||
(if (= 'a (cadr x))
|
||||
'car
|
||||
(if (= 'd (cadr x))
|
||||
'cdr
|
||||
(macro-error "`cxr` expects either `a` or `d` symbols, got " (cadr x))))
|
||||
(if (= 1 (car x))
|
||||
(cxr (cddr x) pair)
|
||||
(cxr (cons (- (car x) 1) (cdr x)) pair)))))
|
||||
|
||||
(defndynamic nthcdr [n pair]
|
||||
(cxr (list (+ n 1) 'd) pair))
|
||||
|
||||
(defndynamic nthcar [n pair]
|
||||
(cxr (list 1 'a n 'd) pair))
|
||||
|
||||
(defndynamic collect-into-internal [xs acc f]
|
||||
(if (= 0 (length xs))
|
||||
acc
|
||||
(collect-into-internal (cdr xs) (append acc (f (car xs))) f)))
|
||||
|
||||
(doc collect-into
|
||||
"Transforms a dynamic data literal into another, preserving order")
|
||||
(defndynamic collect-into [xs f]
|
||||
(collect-into-internal xs (f) f))
|
||||
|
||||
(doc empty?
|
||||
"Returns true if the provided data literal is empty, false otherwise.")
|
||||
(defndynamic empty? [xs]
|
||||
(= 0 (length xs)))
|
||||
|
||||
(doc reduce
|
||||
"Reduces or 'folds' a data literal, such as a list or array, into a single"
|
||||
"value through successive applications of `f`.")
|
||||
(defndynamic reduce [f x xs]
|
||||
(if (empty? xs)
|
||||
x
|
||||
(reduce f (f x (car xs)) (cdr xs))))
|
||||
|
||||
(hidden unreduce-internal)
|
||||
(defndynamic unreduce-internal [f x lim acc counter]
|
||||
;; Currently only works with anonymous functions and named functions.
|
||||
;; does not work with commands.
|
||||
(if (not (or (array? acc) (list? acc)))
|
||||
(macro-error
|
||||
"Unreduce requires a dynamic data structure to collect results, such as
|
||||
(list) or (array).")
|
||||
(if (= counter lim)
|
||||
acc
|
||||
(unreduce-internal f (f x) lim (append acc (cons (eval (f x)) (empty acc))) (+ counter 1)))))
|
||||
|
||||
(doc unreduce
|
||||
"Applies `f` to a starting value `x`, then generates a sequence of values"
|
||||
"by successively applying `f` to the result `lim-1` times."
|
||||
"Collects results in the structure given by `acc`."
|
||||
""
|
||||
"```"
|
||||
"(unreduce (curry + 1) 0 10 (list))"
|
||||
"=> (1 2 3 4 5 6 7 8 9 10)"
|
||||
"```")
|
||||
(defndynamic unreduce [f x lim acc]
|
||||
(unreduce-internal f x lim acc 0))
|
||||
|
||||
(doc filter
|
||||
"Returns a list containing only the elements of `xs` that satisify"
|
||||
"predicate `p`."
|
||||
""
|
||||
"```"
|
||||
"(filter (fn [x] (= 'a x)) '(a b a b a b a b))"
|
||||
"=> (a a a a)"
|
||||
"```")
|
||||
(defndynamic filter [p xs]
|
||||
(let [filter-fn (fn [x y] (if (p y) (append x (list y)) x))]
|
||||
(reduce filter-fn (list) xs)))
|
||||
|
||||
(doc reverse
|
||||
"Reverses the order of elements in an array or list."
|
||||
""
|
||||
"```"
|
||||
"(reverse [1 2 3 4])"
|
||||
"=> [4 3 2 1]"
|
||||
"```")
|
||||
(defndynamic reverse [xs]
|
||||
(if (array? xs)
|
||||
(reduce (flip append) (array) (map array xs))
|
||||
(reduce (flip append) (list) (map list xs))))
|
||||
|
||||
(doc empty
|
||||
"Returns the empty form of `xs`."
|
||||
""
|
||||
"```"
|
||||
"(empty '(1 2 3 4))"
|
||||
"=> ()"
|
||||
"(empty '[1 2 3 4])"
|
||||
"=> []"
|
||||
"```")
|
||||
(defndynamic empty [xs]
|
||||
(if (array? xs)
|
||||
(array)
|
||||
(list)))
|
||||
|
||||
(doc take
|
||||
"Returns a list containing the first `n` elements of a list."
|
||||
""
|
||||
"```"
|
||||
"(take 3 '(1 2 3 4 5))"
|
||||
"=> (1 2 3)"
|
||||
"```")
|
||||
(defndynamic take [n xs]
|
||||
;; A more straightforward impl is likely more efficient?
|
||||
(let [indicies (unreduce (curry + 1) 0 n (list))
|
||||
result (map cadr (zip list xs indicies))]
|
||||
(if (array? xs)
|
||||
(collect-into result array)
|
||||
result)))
|
||||
|
||||
(doc apply
|
||||
"Applies the function `f` to the provided argument list, passing each value"
|
||||
"in the list as an argument to the function.")
|
||||
(defndynamic apply [f argument-list]
|
||||
;; The let clause here is a tad mysterious at first glance. When passed a
|
||||
;; standalone function name (i.e. not an application (f x), carp evaluates
|
||||
;; it into the function's defining form, e.g. foo becomes (defn foo [x] x),
|
||||
;; commands such as + become (command +) etc. ;; The binding here accounts
|
||||
;; for that case, allowing users to pass the function name to apply
|
||||
;; unquoted.
|
||||
;;
|
||||
;; This is necessary for parity across map-internal, zip, and apply.
|
||||
;; Since map calls its function directly, it takes it as is. Apply, on the
|
||||
;; other hand, would have to take the quoted form, since it builds a list
|
||||
;; that serves as the actual application.
|
||||
;;
|
||||
;; This is problematic for the user facing map function, since it makes
|
||||
;; calls to map or zip (which uses apply) as appropriate--unless we support
|
||||
;; the quoted function name argument in map-internal or the unquoted one in
|
||||
;; apply, we can't use zip and map-internal in map.
|
||||
(if (not (list? f))
|
||||
(f argument-list)
|
||||
(let [function-name (list (cadr f))]
|
||||
(if (array? argument-list)
|
||||
(append function-name (collect-into argument-list list))
|
||||
(append function-name argument-list)))))
|
||||
|
||||
(doc any?
|
||||
"Checks whether any of the elements in `xs` conforms to the predicate"
|
||||
"function `f`."
|
||||
""
|
||||
"```"
|
||||
"(any? (fn [x] (= 'a x)) '(a b c))"
|
||||
"=> true"
|
||||
"(any? (fn [x] (= 'a x)) '(e f g))"
|
||||
"=> false"
|
||||
"```")
|
||||
(defndynamic any? [f xs]
|
||||
(reduce (fn [acc x] (or acc (f x))) false xs))
|
||||
|
||||
(doc all?
|
||||
"Checks whether all of the elements in `xs` conform to the predicate"
|
||||
"function `f`."
|
||||
""
|
||||
"```"
|
||||
"(all? (fn [x] (< 1 x)) '(2 3 4))"
|
||||
"=> true"
|
||||
"(all? (fn [x] (< 1 x)) '(-1 0 1))"
|
||||
"=> false"
|
||||
"```")
|
||||
(defndynamic all? [f xs]
|
||||
(reduce (fn [acc x] (and acc (f x))) true xs))
|
||||
|
||||
(hidden zip-internal)
|
||||
(defndynamic zip-internal [f forms acc]
|
||||
(if (any? empty? forms)
|
||||
acc
|
||||
(zip-internal
|
||||
f
|
||||
(map-internal cdr forms (list))
|
||||
(let [result (list (apply f (map-internal car forms (list))))]
|
||||
(append acc result)))))
|
||||
|
||||
(doc zip
|
||||
"Returns the *form* that results from applying a function `f` to each of"
|
||||
"the values supplied in `forms`."
|
||||
|
||||
"If the members of a single form are exhuasted, the result of the"
|
||||
"applications thus far is returned, and any remaining members in the other"
|
||||
"forms are ignored."
|
||||
""
|
||||
"```"
|
||||
"(zip + '(1 2 3) '(4 5 6))"
|
||||
"=> ((+ 1 4) (+ 2 5) (+ 3 6))"
|
||||
"```"
|
||||
""
|
||||
"It's important to note that zip operates on forms, and that the form"
|
||||
"returned by zip may not be evaluable by itself. For instance, to actually"
|
||||
"transform the result in the example above into something Carp can"
|
||||
"evaluate, we need to wrap each member of the list in a `do`:"
|
||||
""
|
||||
"```"
|
||||
"(append (list 'do) (zip + '(1 2 3) '(4 5 6)))"
|
||||
"=> (do (+ 1 4) (+ 2 5) (+ 3 6))"
|
||||
"(eval (append (list 'do) (zip + '(1 2 3) '(4 5 6))))"
|
||||
"=> 9 ;; do returns the value of the last form in its body"
|
||||
"```")
|
||||
(defndynamic zip [f :rest forms]
|
||||
(zip-internal f forms (list)))
|
||||
|
||||
(doc map
|
||||
"Applies a function `f` to each element in the list or array `xs` and"
|
||||
"returns a list dynamic data literal containing the result of the function"
|
||||
"applications."
|
||||
""
|
||||
"```"
|
||||
"'(map symbol? '(a b c))"
|
||||
"=> (true true true)"
|
||||
"'(map (curry + 1) '(1 2 3))"
|
||||
"=> (2 3 4)"
|
||||
"```")
|
||||
(defndynamic map [f xs]
|
||||
(map-internal f xs (list)))
|
||||
|
||||
(doc flatten
|
||||
"Flattens a list recursively."
|
||||
""
|
||||
"```"
|
||||
"(flatten '(1 2 (3 (4))))"
|
||||
"=> '(1 2 3 4)"
|
||||
"```")
|
||||
(defndynamic flatten [l]
|
||||
(reduce (fn [acc x]
|
||||
(if (list? x)
|
||||
(append acc (flatten x))
|
||||
(cons-last x acc)))
|
||||
'()
|
||||
l))
|
||||
|
||||
)
|
702
core/Macros.carp
702
core/Macros.carp
@ -17,6 +17,36 @@
|
||||
acc
|
||||
(list-to-array-internal (cdr xs) (append acc (array (car xs))))))
|
||||
|
||||
(defmodule Dynamic
|
||||
(defndynamic caar [pair] (car (car pair)))
|
||||
(defndynamic cadr [pair] (car (cdr pair)))
|
||||
(defndynamic cdar [pair] (cdr (car pair)))
|
||||
(defndynamic cddr [pair] (cdr (cdr pair)))
|
||||
(defndynamic caaar [pair] (car (car (car pair))))
|
||||
(defndynamic caadr [pair] (car (car (cdr pair))))
|
||||
(defndynamic cadar [pair] (car (cdr (car pair))))
|
||||
(defndynamic cdaar [pair] (cdr (car (car pair))))
|
||||
(defndynamic caddr [pair] (car (cdr (cdr pair))))
|
||||
(defndynamic cdadr [pair] (cdr (car (cdr pair))))
|
||||
(defndynamic cddar [pair] (cdr (cdr (car pair))))
|
||||
(defndynamic cdddr [pair] (cdr (cdr (cdr pair))))
|
||||
(defndynamic caaaar [pair] (car (car (car (car pair)))))
|
||||
(defndynamic caaadr [pair] (car (car (car (cdr pair)))))
|
||||
(defndynamic caadar [pair] (car (car (cdr (car pair)))))
|
||||
(defndynamic caaddr [pair] (car (car (cdr (cdr pair)))))
|
||||
(defndynamic cadaar [pair] (car (cdr (car (car pair)))))
|
||||
(defndynamic cadadr [pair] (car (cdr (car (cdr pair)))))
|
||||
(defndynamic caddar [pair] (car (cdr (cdr (car pair)))))
|
||||
(defndynamic cadddr [pair] (car (cdr (cdr (cdr pair)))))
|
||||
(defndynamic cdaaar [pair] (cdr (car (car (car pair)))))
|
||||
(defndynamic cdaadr [pair] (cdr (car (car (cdr pair)))))
|
||||
(defndynamic cdadar [pair] (cdr (car (cdr (car pair)))))
|
||||
(defndynamic cdaddr [pair] (cdr (car (cdr (cdr pair)))))
|
||||
(defndynamic cddaar [pair] (cdr (cdr (car (car pair)))))
|
||||
(defndynamic cddadr [pair] (cdr (cdr (car (cdr pair)))))
|
||||
(defndynamic cdddar [pair] (cdr (cdr (cdr (car pair)))))
|
||||
(defndynamic cddddr [pair] (cdr (cdr (cdr (cdr pair))))))
|
||||
|
||||
(meta-set! doc "doc" "Set documentation for a binding.")
|
||||
(defmacro doc [name :rest strings]
|
||||
(let [newline "
|
||||
@ -69,401 +99,13 @@
|
||||
(defmacro annotate [name annotation]
|
||||
(eval (list 'meta-set! name "annotations" (eval (annotate-helper name annotation)))))
|
||||
|
||||
(doc implements? "Does `function` implement `interface`?")
|
||||
(defmacro implements? [interface function]
|
||||
(eval (list 'any? (list 'fn (array 'x) (list '= 'x interface)) (list 'meta function "implements"))))
|
||||
|
||||
(defmodule Dynamic
|
||||
(defndynamic caar [pair] (car (car pair)))
|
||||
(defndynamic cadr [pair] (car (cdr pair)))
|
||||
(defndynamic cdar [pair] (cdr (car pair)))
|
||||
(defndynamic cddr [pair] (cdr (cdr pair)))
|
||||
(defndynamic caaar [pair] (car (car (car pair))))
|
||||
(defndynamic caadr [pair] (car (car (cdr pair))))
|
||||
(defndynamic cadar [pair] (car (cdr (car pair))))
|
||||
(defndynamic cdaar [pair] (cdr (car (car pair))))
|
||||
(defndynamic caddr [pair] (car (cdr (cdr pair))))
|
||||
(defndynamic cdadr [pair] (cdr (car (cdr pair))))
|
||||
(defndynamic cddar [pair] (cdr (cdr (car pair))))
|
||||
(defndynamic cdddr [pair] (cdr (cdr (cdr pair))))
|
||||
(defndynamic caaaar [pair] (car (car (car (car pair)))))
|
||||
(defndynamic caaadr [pair] (car (car (car (cdr pair)))))
|
||||
(defndynamic caadar [pair] (car (car (cdr (car pair)))))
|
||||
(defndynamic caaddr [pair] (car (car (cdr (cdr pair)))))
|
||||
(defndynamic cadaar [pair] (car (cdr (car (car pair)))))
|
||||
(defndynamic cadadr [pair] (car (cdr (car (cdr pair)))))
|
||||
(defndynamic caddar [pair] (car (cdr (cdr (car pair)))))
|
||||
(defndynamic cadddr [pair] (car (cdr (cdr (cdr pair)))))
|
||||
(defndynamic cdaaar [pair] (cdr (car (car (car pair)))))
|
||||
(defndynamic cdaadr [pair] (cdr (car (car (cdr pair)))))
|
||||
(defndynamic cdadar [pair] (cdr (car (cdr (car pair)))))
|
||||
(defndynamic cdaddr [pair] (cdr (car (cdr (cdr pair)))))
|
||||
(defndynamic cddaar [pair] (cdr (cdr (car (car pair)))))
|
||||
(defndynamic cddadr [pair] (cdr (cdr (car (cdr pair)))))
|
||||
(defndynamic cdddar [pair] (cdr (cdr (cdr (car pair)))))
|
||||
(defndynamic cddddr [pair] (cdr (cdr (cdr (cdr pair)))))
|
||||
|
||||
(defndynamic cxr [x pair]
|
||||
(if (= (length x) 0)
|
||||
(list 'quote pair)
|
||||
(list
|
||||
(if (= 'a (cadr x))
|
||||
'car
|
||||
(if (= 'd (cadr x))
|
||||
'cdr
|
||||
(macro-error "`cxr` expects either `a` or `d` symbols, got " (cadr x))))
|
||||
(if (= 1 (car x))
|
||||
(cxr (cddr x) pair)
|
||||
(cxr (cons (- (car x) 1) (cdr x)) pair)))))
|
||||
|
||||
(defndynamic nthcdr [n pair]
|
||||
(cxr (list (+ n 1) 'd) pair))
|
||||
|
||||
(defndynamic nthcar [n pair]
|
||||
(cxr (list 1 'a n 'd) pair))
|
||||
|
||||
(defndynamic eval-internal [form]
|
||||
(list 'do
|
||||
(list 'defn 'main [] (list 'IO.println* form))
|
||||
(list 'build)
|
||||
(list 'run)))
|
||||
|
||||
(defmacro evaluate [form]
|
||||
(eval-internal form))
|
||||
|
||||
(defmacro e [form]
|
||||
(eval-internal form))
|
||||
|
||||
(defndynamic collect-into-internal [xs acc f]
|
||||
(if (= 0 (length xs))
|
||||
acc
|
||||
(collect-into-internal (cdr xs) (append acc (f (car xs))) f)))
|
||||
|
||||
(doc collect-into
|
||||
"Transforms a dynamic data literal into another, preserving order")
|
||||
(defndynamic collect-into [xs f]
|
||||
(collect-into-internal xs (f) f))
|
||||
|
||||
(doc empty?
|
||||
"Returns true if the provided data literal is empty, false otherwise.")
|
||||
(defndynamic empty? [xs]
|
||||
(= 0 (length xs)))
|
||||
|
||||
(doc flip
|
||||
"Flips the arguments of a function `f`."
|
||||
"```"
|
||||
"((flip Symbol.prefix) 'Bar 'Foo)"
|
||||
"=> (Foo.Bar)"
|
||||
"```")
|
||||
(defndynamic flip [f]
|
||||
(fn [x y]
|
||||
(f y x)))
|
||||
|
||||
(doc compose
|
||||
"Returns the composition of two functions `f` and `g` for functions of any"
|
||||
"arity; concretely, returns a function accepting the correct number of"
|
||||
"arguments for `g`, applies `g` to those arguments, then applies `f` to the"
|
||||
"result."
|
||||
""
|
||||
"If you only need to compose functions that take a single argument (unary arity)"
|
||||
"see `comp`. Comp also generates the form that corresponds to the composition,"
|
||||
"compose contrarily evaluates 'eagerly' and returns a computed symbol."
|
||||
"```"
|
||||
";; a silly composition"
|
||||
"((compose empty take) 3 [1 2 3 4 5])"
|
||||
";; => []"
|
||||
""
|
||||
"(String.join (collect-into ((compose reverse map) Symbol.str '(p r a c)) array))"
|
||||
";; => 'carp'"
|
||||
""
|
||||
";; comp for comparison"
|
||||
"((comp (curry + 1) (curry + 2)) 4)"
|
||||
";; => (+ 1 (+ 2 4))"
|
||||
"```")
|
||||
(defndynamic compose [f g]
|
||||
;; Recall that **unquoted** function names evaluate to their definitions in
|
||||
;; dynamic contexts, e.g. f = (dyanmic f [arg] body)
|
||||
;;
|
||||
;; Right now, this cannot handle anonymous functions because they cannot be passed to apply.
|
||||
;; and not anonymous functions.
|
||||
;; commands expand to (command <name>), fns expand to a non-list.
|
||||
;;
|
||||
;; TODO: Support passing anonymous functions.
|
||||
(if (not (or (list? f) (list? g)))
|
||||
(macro-error "compose can only compose named dynamic functions. To
|
||||
compose anonymous functions, such as curried functions,
|
||||
see comp.")
|
||||
(let [f-name (cadr f)
|
||||
g-name (cadr g)
|
||||
arguments (caddr g)]
|
||||
(list 'fn arguments
|
||||
;; Since we call an eval to apply g immediately, we wrap the args in an
|
||||
;; extra quote, otherwise, users would need to double quote any sequence of
|
||||
;; symbols such as '(p r a c)
|
||||
(list f-name (list 'eval (list 'apply g-name (list 'quote arguments))))))))
|
||||
|
||||
(doc curry
|
||||
"Returns a curried function accepting a single argument, that applies `f` to `x`"
|
||||
"and then to the following argument."
|
||||
""
|
||||
"```"
|
||||
"(map (curry Symbol.prefix 'Foo) '(bar baz))"
|
||||
"=> (Foo.bar Foo.baz)"
|
||||
"```")
|
||||
(defndynamic curry [f x]
|
||||
(fn [y]
|
||||
(f x y)))
|
||||
|
||||
(doc curry*
|
||||
"Curry functions of any arity."
|
||||
""
|
||||
"```"
|
||||
"(map (curry* Dynamic.zip + '(1 2 3)) '((4 5) (6)))"
|
||||
"=> (((+ 1 4) (+ 2 5)) ((+ 1 6)))"
|
||||
""
|
||||
"((curry* Dynamic.zip cons '(1 2 3)) '((4 5) (6)))"
|
||||
"=> ((cons 1 (4 5)) (cons (2 (6))))"
|
||||
""
|
||||
"(defndynamic add-em-up [x y z] (+ (+ x y) z))"
|
||||
"(map (curry* add-em-up 1 2) '(1 2 3))"
|
||||
"=> (4 5 6)"
|
||||
"```")
|
||||
(defndynamic curry* [f :rest args]
|
||||
(let [f-name (cadr f)
|
||||
all-args (caddr f)
|
||||
unfilled-args (- (length all-args) (length args))
|
||||
remaining (take unfilled-args all-args)
|
||||
;; Quote the arguments to retain expected behavior and avoid the need
|
||||
;; for double quotes in curried higher-orders, e.g. zip.
|
||||
quote-args (map quoted args)]
|
||||
(list 'fn remaining
|
||||
;; eval to execute the curried function.
|
||||
;; otherwise, this resolves to the form that will call the function, e.g. (add-three-vals 2 3 1)
|
||||
(list 'eval (list 'apply f-name (list 'quote (append quote-args (collect-into
|
||||
remaining list))))))))
|
||||
|
||||
;; Higher-order functions can't currently accept primitives
|
||||
;; For now, wrapping primitives in a function allows us to pass them
|
||||
;; to HOFs like map.
|
||||
(defndynamic quoted [x]
|
||||
(list 'quote x))
|
||||
|
||||
(doc reduce
|
||||
"Reduces or 'folds' a data literal, such as a list or array, into a single"
|
||||
"value through successive applications of `f`.")
|
||||
(defndynamic reduce [f x xs]
|
||||
(if (empty? xs)
|
||||
x
|
||||
(reduce f (f x (car xs)) (cdr xs))))
|
||||
|
||||
(hidden unreduce-internal)
|
||||
(defndynamic unreduce-internal [f x lim acc counter]
|
||||
;; Currently only works with anonymous functions and named functions.
|
||||
;; does not work with commands.
|
||||
(if (not (or (array? acc) (list? acc)))
|
||||
(macro-error
|
||||
"Unreduce requires a dynamic data structure to collect results, such as
|
||||
(list) or (array).")
|
||||
(if (= counter lim)
|
||||
acc
|
||||
(unreduce-internal f (f x) lim (append acc (cons (eval (f x)) (empty acc))) (+ counter 1)))))
|
||||
|
||||
(doc unreduce
|
||||
"Applies `f` to a starting value `x`, then generates a sequence of values"
|
||||
"by successively applying `f` to the result `lim-1` times."
|
||||
"Collects results in the structure given by `acc`."
|
||||
""
|
||||
"```"
|
||||
"(unreduce (curry + 1) 0 10 (list))"
|
||||
"=> (1 2 3 4 5 6 7 8 9 10)"
|
||||
"```")
|
||||
(defndynamic unreduce [f x lim acc]
|
||||
(unreduce-internal f x lim acc 0))
|
||||
|
||||
(doc filter
|
||||
"Returns a list containing only the elements of `xs` that satisify"
|
||||
"predicate `p`."
|
||||
""
|
||||
"```"
|
||||
"(filter (fn [x] (= 'a x)) '(a b a b a b a b))"
|
||||
"=> (a a a a)"
|
||||
"```")
|
||||
(defndynamic filter [p xs]
|
||||
(let [filter-fn (fn [x y] (if (p y) (append x (list y)) x))]
|
||||
(reduce filter-fn (list) xs)))
|
||||
|
||||
(doc reverse
|
||||
"Reverses the order of elements in an array or list."
|
||||
""
|
||||
"```"
|
||||
"(reverse [1 2 3 4])"
|
||||
"=> [4 3 2 1]"
|
||||
"```")
|
||||
(defndynamic reverse [xs]
|
||||
(if (array? xs)
|
||||
(reduce (flip append) (array) (map array xs))
|
||||
(reduce (flip append) (list) (map list xs))))
|
||||
|
||||
(doc empty
|
||||
"Returns the empty form of `xs`."
|
||||
""
|
||||
"```"
|
||||
"(empty '(1 2 3 4))"
|
||||
"=> ()"
|
||||
"(empty '[1 2 3 4])"
|
||||
"=> []"
|
||||
"```")
|
||||
(defndynamic empty [xs]
|
||||
(if (array? xs)
|
||||
(array)
|
||||
(list)))
|
||||
|
||||
(doc take
|
||||
"Returns a list containing the first `n` elements of a list."
|
||||
""
|
||||
"```"
|
||||
"(take 3 '(1 2 3 4 5))"
|
||||
"=> (1 2 3)"
|
||||
"```")
|
||||
(defndynamic take [n xs]
|
||||
;; A more straightforward impl is likely more efficient?
|
||||
(let [indicies (unreduce (curry + 1) 0 n (list))
|
||||
result (map cadr (zip list xs indicies))]
|
||||
(if (array? xs)
|
||||
(collect-into result array)
|
||||
result)))
|
||||
|
||||
(doc apply
|
||||
"Applies the function `f` to the provided argument list, passing each value"
|
||||
"in the list as an argument to the function.")
|
||||
(defndynamic apply [f argument-list]
|
||||
;; The let clause here is a tad mysterious at first glance. When passed a
|
||||
;; standalone function name (i.e. not an application (f x), carp evaluates
|
||||
;; it into the function's defining form, e.g. foo becomes (defn foo [x] x),
|
||||
;; commands such as + become (command +) etc. ;; The binding here accounts
|
||||
;; for that case, allowing users to pass the function name to apply
|
||||
;; unquoted.
|
||||
;;
|
||||
;; This is necessary for parity across map-internal, zip, and apply.
|
||||
;; Since map calls its function directly, it takes it as is. Apply, on the
|
||||
;; other hand, would have to take the quoted form, since it builds a list
|
||||
;; that serves as the actual application.
|
||||
;;
|
||||
;; This is problematic for the user facing map function, since it makes
|
||||
;; calls to map or zip (which uses apply) as appropriate--unless we support
|
||||
;; the quoted function name argument in map-internal or the unquoted one in
|
||||
;; apply, we can't use zip and map-internal in map.
|
||||
(if (not (list? f))
|
||||
(f argument-list)
|
||||
(let [function-name (list (cadr f))]
|
||||
(if (array? argument-list)
|
||||
(append function-name (collect-into argument-list list))
|
||||
(append function-name argument-list)))))
|
||||
|
||||
|
||||
|
||||
(doc any?
|
||||
"Checks whether any of the elements in `xs` conforms to the predicate"
|
||||
"function `f`."
|
||||
""
|
||||
"```"
|
||||
"(any? (fn [x] (= 'a x)) '(a b c))"
|
||||
"=> true"
|
||||
"(any? (fn [x] (= 'a x)) '(e f g))"
|
||||
"=> false"
|
||||
"```")
|
||||
(defndynamic any? [f xs]
|
||||
(reduce (fn [acc x] (or acc (f x))) false xs))
|
||||
|
||||
(doc all?
|
||||
"Checks whether all of the elements in `xs` conform to the predicate"
|
||||
"function `f`."
|
||||
""
|
||||
"```"
|
||||
"(all? (fn [x] (< 1 x)) '(2 3 4))"
|
||||
"=> true"
|
||||
"(all? (fn [x] (< 1 x)) '(-1 0 1))"
|
||||
"=> false"
|
||||
"```")
|
||||
(defndynamic all? [f xs]
|
||||
(reduce (fn [acc x] (and acc (f x))) true xs))
|
||||
|
||||
(hidden zip-internal)
|
||||
(defndynamic zip-internal [f forms acc]
|
||||
(if (any? empty? forms)
|
||||
acc
|
||||
(zip-internal
|
||||
f
|
||||
(map-internal cdr forms (list))
|
||||
(let [result (list (apply f (map-internal car forms (list))))]
|
||||
(append acc result)))))
|
||||
|
||||
(doc zip
|
||||
"Returns the *form* that results from applying a function `f` to each of"
|
||||
"the values supplied in `forms`."
|
||||
|
||||
"If the members of a single form are exhuasted, the result of the"
|
||||
"applications thus far is returned, and any remaining members in the other"
|
||||
"forms are ignored."
|
||||
""
|
||||
"```"
|
||||
"(zip + '(1 2 3) '(4 5 6))"
|
||||
"=> ((+ 1 4) (+ 2 5) (+ 3 6))"
|
||||
"```"
|
||||
""
|
||||
"It's important to note that zip operates on forms, and that the form"
|
||||
"returned by zip may not be evaluable by itself. For instance, to actually"
|
||||
"transform the result in the example above into something Carp can"
|
||||
"evaluate, we need to wrap each member of the list in a `do`:"
|
||||
""
|
||||
"```"
|
||||
"(append (list 'do) (zip + '(1 2 3) '(4 5 6)))"
|
||||
"=> (do (+ 1 4) (+ 2 5) (+ 3 6))"
|
||||
"(eval (append (list 'do) (zip + '(1 2 3) '(4 5 6))))"
|
||||
"=> 9 ;; do returns the value of the last form in its body"
|
||||
"```")
|
||||
(defndynamic zip [f :rest forms]
|
||||
(zip-internal f forms (list)))
|
||||
|
||||
(doc map
|
||||
"Applies a function `f` to each element in the list or array `xs` and"
|
||||
"returns a list dynamic data literal containing the result of the function"
|
||||
"applications."
|
||||
""
|
||||
"```"
|
||||
"'(map symbol? '(a b c))"
|
||||
"=> (true true true)"
|
||||
"'(map (curry + 1) '(1 2 3))"
|
||||
"=> (2 3 4)"
|
||||
"```")
|
||||
(defndynamic map [f xs]
|
||||
(map-internal f xs (list)))
|
||||
|
||||
(doc flatten
|
||||
"Flattens a list recursively."
|
||||
""
|
||||
"```"
|
||||
"(flatten '(1 2 (3 (4))))"
|
||||
"=> '(1 2 3 4)"
|
||||
"```")
|
||||
(defndynamic flatten [l]
|
||||
(reduce (fn [acc x]
|
||||
(if (list? x)
|
||||
(append acc (flatten x))
|
||||
(cons-last x acc)))
|
||||
'()
|
||||
l))
|
||||
)
|
||||
|
||||
(defndynamic implement-declaration [mod interface]
|
||||
(list 'implements interface (Symbol.prefix mod interface)))
|
||||
|
||||
(doc implements-all
|
||||
"Declares functions in mod with names matching `interfaces` as implementations"
|
||||
"of those interfaces.")
|
||||
(defmacro implements-all [mod :rest interfaces]
|
||||
(cons 'do (map (curry implement-declaration mod) interfaces)))
|
||||
|
||||
(defndynamic cond-internal [xs]
|
||||
(if (= (length xs) 0)
|
||||
(list)
|
||||
@ -490,85 +132,10 @@
|
||||
(defmacro cond [:rest xs]
|
||||
(cond-internal xs))
|
||||
|
||||
(defmacro for [settings :rest body] ;; settings = variable, from, to, <step>
|
||||
(if (> (length body) 1)
|
||||
(macro-error "Warning: the body of the 'for' loop can only contain one expression")
|
||||
(let [variable (car settings)
|
||||
from (cadr settings)
|
||||
to (caddr settings)
|
||||
step (if (> (length settings) 3) (cadddr settings) 1)
|
||||
comp (if (> (length settings) 4)
|
||||
(cadddr (cdr settings))
|
||||
(if (< step (- step step)) '> '<))
|
||||
]
|
||||
(list
|
||||
'let (array variable from)
|
||||
(list
|
||||
'while (list comp variable to)
|
||||
(list
|
||||
'do
|
||||
(if (= (length body) 0)
|
||||
()
|
||||
(if (list? body)
|
||||
(car body)
|
||||
body))
|
||||
(list
|
||||
'set! variable
|
||||
(list '+ variable step))))))))
|
||||
|
||||
(defmacro refstr [x]
|
||||
(list 'ref
|
||||
(list 'str x)))
|
||||
|
||||
(defmacro doall [f xs]
|
||||
(list 'for ['i 0 (list 'Array.length (list 'ref xs))]
|
||||
(list f (list 'Array.unsafe-nth (list 'ref xs) 'i))))
|
||||
|
||||
(defndynamic foreach-internal [var xs expr]
|
||||
(let [xsym (gensym-with 'xs)
|
||||
len (gensym-with 'len)
|
||||
i (gensym-with 'i)]
|
||||
(list 'let [xsym xs
|
||||
len (list 'Array.length xsym)]
|
||||
(list 'for [i 0 len]
|
||||
(list 'let [var (list 'Array.unsafe-nth xsym i)]
|
||||
expr)))))
|
||||
|
||||
(defmacro foreach [binding expr]
|
||||
(if (array? binding)
|
||||
(foreach-internal (car binding) (cadr binding) expr)
|
||||
(macro-error "Binding has to be an array.")))
|
||||
|
||||
(defndynamic thread-first-internal [xs]
|
||||
(if (= (length xs) 2)
|
||||
(if (list? (last xs))
|
||||
(cons (caadr xs)
|
||||
(cons (car xs)
|
||||
(cdadr xs)))
|
||||
(list (cadr xs) (car xs)))
|
||||
(if (list? (last xs))
|
||||
(append
|
||||
(list
|
||||
(car (last xs))
|
||||
(thread-first-internal (all-but-last xs)))
|
||||
(cdr (last xs)))
|
||||
(list (last xs) (thread-first-internal (all-but-last xs))))))
|
||||
|
||||
(defndynamic thread-last-internal [xs]
|
||||
(if (= (length xs) 2)
|
||||
(if (list? (last xs))
|
||||
(cons-last (car xs) (last xs))
|
||||
(list (cadr xs) (car xs)))
|
||||
(if (list? (last xs))
|
||||
(cons-last (thread-last-internal (all-but-last xs)) (last xs))
|
||||
(list (last xs) (thread-last-internal (all-but-last xs))))))
|
||||
|
||||
(defmacro => [:rest forms]
|
||||
(thread-first-internal forms))
|
||||
|
||||
(defmacro ==> [:rest forms]
|
||||
(thread-last-internal forms))
|
||||
|
||||
(defmacro swap! [x y]
|
||||
(list 'let (array 'tmp y) (list 'do (list 'set! y x) (list 'set! x 'tmp))))
|
||||
|
||||
@ -592,44 +159,9 @@
|
||||
(eval (list 'load (str name ".carp")))
|
||||
(eval (list 'use name))))
|
||||
|
||||
(defmacro when [condition form]
|
||||
(list 'if condition form (list)))
|
||||
|
||||
(defmacro unless [condition form]
|
||||
(list 'if condition (list) form))
|
||||
|
||||
(defmacro let-do [bindings :rest forms]
|
||||
(list 'let bindings
|
||||
(cons 'do forms)))
|
||||
|
||||
(defmacro while-do [condition :rest forms]
|
||||
(list 'while condition
|
||||
(cons 'do forms)))
|
||||
|
||||
(defmacro defn-do [name arguments :rest body]
|
||||
(eval (list 'defn name arguments (cons 'do body))))
|
||||
|
||||
(defmacro comment [:rest forms]
|
||||
())
|
||||
|
||||
(defmacro forever-do [:rest forms]
|
||||
(list 'while true (cons 'do forms)))
|
||||
|
||||
(defndynamic case-internal [name xs]
|
||||
(if (= (length xs) 0)
|
||||
(list)
|
||||
(if (= (length xs) 2)
|
||||
(macro-error "case has even number of branches; add an else branch")
|
||||
(if (= (length xs) 1)
|
||||
(car xs)
|
||||
(list 'if
|
||||
(list '= name (car xs))
|
||||
(cadr xs)
|
||||
(case-internal name (cddr xs)))))))
|
||||
|
||||
(defmacro case [name :rest forms]
|
||||
(case-internal name forms))
|
||||
|
||||
(defndynamic build-vararg [func forms]
|
||||
(if (= (length forms) 0)
|
||||
(macro-error "vararg macro needs at least one argument")
|
||||
@ -643,39 +175,9 @@
|
||||
(defmacro or* [:rest forms]
|
||||
(build-vararg 'or forms))
|
||||
|
||||
(defndynamic build-str* [forms]
|
||||
(if (= (length forms) 0)
|
||||
(list "")
|
||||
(if (= (length forms) 1)
|
||||
(list 'ref (list 'str (car forms)))
|
||||
(list 'ref (list 'String.append (list 'ref (list 'str (car forms))) (build-str* (cdr forms)))))))
|
||||
|
||||
(defmacro str* [:rest forms]
|
||||
(list 'copy (build-str* forms)))
|
||||
|
||||
(defmacro println* [:rest forms]
|
||||
(list 'IO.println (build-str* forms)))
|
||||
|
||||
(defmacro print* [:rest forms]
|
||||
(list 'IO.print (build-str* forms)))
|
||||
|
||||
(defmacro ignore [form]
|
||||
(list 'let (array '_ form) (list)))
|
||||
|
||||
(defmacro save-docs [:rest modules]
|
||||
;; A trick to be able to send unquoted symbols to 'save-docs'
|
||||
(eval (list 'save-docs-internal (list 'quote modules))))
|
||||
|
||||
(defndynamic project-config [bindings]
|
||||
(if (< (length bindings) 2)
|
||||
(list)
|
||||
(cons-last (project-config (cdr (cdr bindings))) (list 'do (list 'Project.config
|
||||
(car bindings) (car (cdr bindings)))))))
|
||||
|
||||
(doc defproject "Define a project configuration.")
|
||||
(defmacro defproject [:rest bindings]
|
||||
(project-config bindings))
|
||||
|
||||
(doc const-assert
|
||||
"Asserts that the expression `expr` is true at compile time."
|
||||
"Otherwise it will fail with the message `msg`."
|
||||
@ -684,43 +186,12 @@
|
||||
(defndynamic const-assert [expr msg]
|
||||
(if expr () (macro-error msg)))
|
||||
|
||||
(doc *gensym-counter* "Is a helper counter for `gensym`.")
|
||||
(defdynamic *gensym-counter* 1000)
|
||||
|
||||
(defndynamic gensym-local [x]
|
||||
(Symbol.concat ['gensym-generated x]))
|
||||
|
||||
(doc gensym-with "Generates symbols dynamically, based on a symbol name.")
|
||||
(defndynamic gensym-with [x]
|
||||
(do
|
||||
(set! *gensym-counter* (inc *gensym-counter*))
|
||||
(Symbol.concat [x (Symbol.from *gensym-counter*)])))
|
||||
|
||||
(doc gensym "Generates symbols dynamically as needed.")
|
||||
(defndynamic gensym []
|
||||
(gensym-with 'gensym-generated))
|
||||
|
||||
(doc until "Executes `body` until the condition `cnd` is true.")
|
||||
(defmacro until [cnd body]
|
||||
(list 'while (list 'not cnd)
|
||||
body))
|
||||
|
||||
(doc defdynamic-once "Creates a dynamic variable and sets its value if it's not already defined.")
|
||||
(defmacro defdynamic-once [var expr]
|
||||
(list 'if (list 'defined? var)
|
||||
()
|
||||
(list 'defdynamic var expr)))
|
||||
|
||||
(defndynamic comp-internal [sym fns]
|
||||
(if (= (length fns) 0)
|
||||
sym
|
||||
(list (car fns) (comp-internal sym (cdr fns)))))
|
||||
|
||||
(doc comp "Composes the functions `fns` into one `fn`.")
|
||||
(defmacro comp [:rest fns]
|
||||
(let [x (gensym)]
|
||||
(list 'fn [x] (comp-internal x fns))))
|
||||
|
||||
(doc inline-c "Inlines some custom C code.")
|
||||
(defmacro inline-c [name defcode :rest declcode]
|
||||
(eval (list 'deftemplate name (list) defcode (if (empty? declcode) "" (car declcode)))))
|
||||
@ -742,108 +213,15 @@
|
||||
(list 'System.abort)
|
||||
(list 'bottom)))
|
||||
|
||||
(doc doto
|
||||
"Evaluates `thing`, then calls all of the functions on it and"
|
||||
"returns it. Useful for chaining mutating, imperative functions, and thus"
|
||||
"similar to `->`. If you need `thing` to be passed as a `ref` into `expressions`"
|
||||
"functions, use [`doto-ref`](#doto-ref) instead."
|
||||
""
|
||||
"```"
|
||||
"(let [x @\"hi\"]"
|
||||
" @(doto &x"
|
||||
" (string-set! 0 \o)"
|
||||
" (string-set! 1 \y)))"
|
||||
"```")
|
||||
(defmacro doto [thing :rest expressions]
|
||||
(let [s (gensym)]
|
||||
(list 'let [s thing]
|
||||
(cons-last
|
||||
s
|
||||
(cons 'do (map (fn [expr] (cons (car expr) (cons s (cdr expr)))) expressions))))))
|
||||
(defmacro save-docs [:rest modules]
|
||||
;; A trick to be able to send unquoted symbols to 'save-docs'
|
||||
(eval (list 'save-docs-internal (list 'quote modules))))
|
||||
|
||||
(doc doto-ref
|
||||
"Evaluates `thing`, then calls all of the functions on it and"
|
||||
"returns it. Useful for chaining mutating, imperative functions, and thus"
|
||||
"similar to `->`. If you need `thing` not to be passed as a `ref` into"
|
||||
"`expressions` functions, use [`doto`](#doto) instead."
|
||||
""
|
||||
"```"
|
||||
"(doto-ref @\"hi\""
|
||||
" (string-set! 0 \o)"
|
||||
" (string-set! 1 \y))"
|
||||
"```")
|
||||
(defmacro doto-ref [thing :rest expressions]
|
||||
(let [s (gensym)]
|
||||
(list 'let [s thing]
|
||||
(cons-last
|
||||
s
|
||||
(cons 'do
|
||||
(map (fn [expr] (cons (car expr) (cons (list 'ref s) (cdr expr))))
|
||||
expressions))))))
|
||||
(defndynamic implement-declaration [mod interface]
|
||||
(list 'implements interface (Symbol.prefix mod interface)))
|
||||
|
||||
(doc native-triple "triple describing the native platform.")
|
||||
|
||||
(defdynamic native-triple [(host-arch) (host-os) "unknown"])
|
||||
|
||||
(doc target-triple "triple describing the target platform.")
|
||||
(defndynamic target-triple []
|
||||
(let [t (Project.get-config "target")]
|
||||
(case t
|
||||
"native" native-triple
|
||||
(Dynamic.String.split-on "-" t))))
|
||||
|
||||
(doc target-arch "target architecture.")
|
||||
(defdynamic target-arch (car (target-triple)))
|
||||
|
||||
(doc target-os "target operating system.")
|
||||
(defdynamic target-os (cadr (target-triple)))
|
||||
|
||||
(doc target-abi "target ABI.")
|
||||
(defdynamic target-abi (caddr (target-triple)))
|
||||
|
||||
(doc target-os? "are we targeting a certain OS?")
|
||||
(defndynamic target-os? [t]
|
||||
(= target-os t))
|
||||
|
||||
(doc windows-target? "are we targeting Windows?")
|
||||
(defdynamic windows-target?
|
||||
(if (target-os? "windows")
|
||||
true
|
||||
(target-os? "mingw32")))
|
||||
|
||||
(doc linux-target? "are we targeting Linux?")
|
||||
(defdynamic linux-target? (target-os? "linux"))
|
||||
|
||||
(doc mac-target? "are we targeting Mac?")
|
||||
(defdynamic mac-target? (target-os? "darwin"))
|
||||
|
||||
(doc freebsd-target? "are we targeting FreeBSD?")
|
||||
(defdynamic freebsd-target? (target-os? "freebsd"))
|
||||
|
||||
(doc posix-target? "are we targeting a POSIX platform?")
|
||||
(defdynamic posix-target? (= false windows-target?))
|
||||
|
||||
(doc target-only "conditionally compile forms when b is true.")
|
||||
(defndynamic target-only [b forms]
|
||||
(when b
|
||||
(eval (cons 'do forms))))
|
||||
|
||||
(doc mac-only "compile forms only on Mac.")
|
||||
(defmacro mac-only [:rest forms]
|
||||
(target-only mac-target? forms))
|
||||
|
||||
(doc linux-only "compile forms only on Linux.")
|
||||
(defmacro linux-only [:rest forms]
|
||||
(target-only linux-target? forms))
|
||||
|
||||
(doc freebsd-only "compile forms only on FreeBSD.")
|
||||
(defmacro freebsd-only [:rest forms]
|
||||
(target-only freebsd-target? forms))
|
||||
|
||||
(doc windows-only "compile forms only on Windows.")
|
||||
(defmacro windows-only [:rest forms]
|
||||
(target-only windows-target? forms))
|
||||
|
||||
(doc posix-only "compile forms only on POSIX targets.")
|
||||
(defmacro posix-only [:rest forms]
|
||||
(target-only posix-target? forms))
|
||||
(doc implements-all
|
||||
"Declares functions in mod with names matching `interfaces` as implementations"
|
||||
"of those interfaces.")
|
||||
(defmacro implements-all [mod :rest interfaces]
|
||||
(cons 'do (map (curry implement-declaration mod) interfaces)))
|
||||
|
65
core/Platform.carp
Normal file
65
core/Platform.carp
Normal file
@ -0,0 +1,65 @@
|
||||
(doc native-triple "triple describing the native platform.")
|
||||
(defdynamic native-triple [(host-arch) (host-os) "unknown"])
|
||||
|
||||
(doc target-triple "triple describing the target platform.")
|
||||
(defndynamic target-triple []
|
||||
(let [t (Project.get-config "target")]
|
||||
(case t
|
||||
"native" native-triple
|
||||
(Dynamic.String.split-on "-" t))))
|
||||
|
||||
(doc target-arch "target architecture.")
|
||||
(defdynamic target-arch (car (target-triple)))
|
||||
|
||||
(doc target-os "target operating system.")
|
||||
(defdynamic target-os (cadr (target-triple)))
|
||||
|
||||
(doc target-abi "target ABI.")
|
||||
(defdynamic target-abi (caddr (target-triple)))
|
||||
|
||||
(doc target-os? "are we targeting a certain OS?")
|
||||
(defndynamic target-os? [t]
|
||||
(= target-os t))
|
||||
|
||||
(doc windows-target? "are we targeting Windows?")
|
||||
(defdynamic windows-target?
|
||||
(if (target-os? "windows")
|
||||
true
|
||||
(target-os? "mingw32")))
|
||||
|
||||
(doc linux-target? "are we targeting Linux?")
|
||||
(defdynamic linux-target? (target-os? "linux"))
|
||||
|
||||
(doc mac-target? "are we targeting Mac?")
|
||||
(defdynamic mac-target? (target-os? "darwin"))
|
||||
|
||||
(doc freebsd-target? "are we targeting FreeBSD?")
|
||||
(defdynamic freebsd-target? (target-os? "freebsd"))
|
||||
|
||||
(doc posix-target? "are we targeting a POSIX platform?")
|
||||
(defdynamic posix-target? (= false windows-target?))
|
||||
|
||||
(doc target-only "conditionally compile forms when b is true.")
|
||||
(defndynamic target-only [b forms]
|
||||
(when b
|
||||
(eval (cons 'do forms))))
|
||||
|
||||
(doc mac-only "compile forms only on Mac.")
|
||||
(defmacro mac-only [:rest forms]
|
||||
(target-only mac-target? forms))
|
||||
|
||||
(doc linux-only "compile forms only on Linux.")
|
||||
(defmacro linux-only [:rest forms]
|
||||
(target-only linux-target? forms))
|
||||
|
||||
(doc freebsd-only "compile forms only on FreeBSD.")
|
||||
(defmacro freebsd-only [:rest forms]
|
||||
(target-only freebsd-target? forms))
|
||||
|
||||
(doc windows-only "compile forms only on Windows.")
|
||||
(defmacro windows-only [:rest forms]
|
||||
(target-only windows-target? forms))
|
||||
|
||||
(doc posix-only "compile forms only on POSIX targets.")
|
||||
(defmacro posix-only [:rest forms]
|
||||
(target-only posix-target? forms))
|
9
core/Project.carp
Normal file
9
core/Project.carp
Normal file
@ -0,0 +1,9 @@
|
||||
(defndynamic project-config [bindings]
|
||||
(if (< (length bindings) 2)
|
||||
(list)
|
||||
(cons-last (project-config (cdr (cdr bindings))) (list 'do (list 'Project.config
|
||||
(car bindings) (car (cdr bindings)))))))
|
||||
|
||||
(doc defproject "Define a project configuration.")
|
||||
(defmacro defproject [:rest bindings]
|
||||
(project-config bindings))
|
@ -465,3 +465,13 @@
|
||||
(implements str Pointer.str)
|
||||
(defn prn [a] (Pointer.str a))
|
||||
)
|
||||
|
||||
(defndynamic build-str* [forms]
|
||||
(if (= (length forms) 0)
|
||||
(list "")
|
||||
(if (= (length forms) 1)
|
||||
(list 'ref (list 'str (car forms)))
|
||||
(list 'ref (list 'String.append (list 'ref (list 'str (car forms))) (build-str* (cdr forms)))))))
|
||||
|
||||
(defmacro str* [:rest forms]
|
||||
(list 'copy (build-str* forms)))
|
@ -3,6 +3,8 @@
|
||||
(system-include "limits.h")
|
||||
(system-include "carp_stdbool.h")
|
||||
|
||||
(load "Macros.carp")
|
||||
(load "ControlMacros.carp")
|
||||
(load "Interfaces.carp")
|
||||
(load "Bool.carp")
|
||||
(load "Pointer.carp")
|
||||
|
Loading…
Reference in New Issue
Block a user