Carp/core/Macros.carp
2021-05-03 15:14:26 +02:00

356 lines
12 KiB
Plaintext

;; Defining the meta data macros early so that they can be used by all the other code.
(defmacro and [x y]
(list 'if x y false))
(defmacro or [x y]
(list 'if x true y))
;; Defined early so that `doc` can accept a rest arg
(defndynamic map-internal [f xs acc]
(if (= 0 (length xs))
acc
(map-internal f (cdr xs) (cons-last (f (car xs)) acc))))
(defndynamic list-to-array-internal [xs acc]
(if (= 0 (length xs))
acc
(list-to-array-internal (cdr xs) (append acc (array (car xs))))))
(defmodule Dynamic
(defndynamic quoted [x]
(list 'quote x))
(defndynamic /= [a b] (not (= a b)))
(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)))))
(defmodule List
; this should be defined using cond, but is defined before cond
(defndynamic in? [elem l]
(if (empty? l)
false
(if (= elem (car l))
true
(List.in? elem (cdr l))))))
(defndynamic string? [s]
(= (dynamic-type s) 'string))
(defndynamic symbol? [s]
(= (dynamic-type s) 'symbol))
(defndynamic list? [s]
(= (dynamic-type s) 'list))
(defndynamic array? [s]
(= (dynamic-type s) 'array))
(defndynamic number? [s]
(List.in? (dynamic-type s) '(int long double float byte))))
(meta-set! doc "doc" "Set documentation for a binding.")
(defmacro doc [name :rest strings]
(let [newline "
" ;; Looks a bit odd but the newline literal is important here! (str \newline) currently results in unwanted escapes
separated (map-internal (fn [x] (if (list? x)
(if (cadr x)
(Dynamic.String.concat [(car x) newline])
(car x))
(Dynamic.String.concat [x newline])))
strings
())]
(list 'meta-set! name "doc" (Dynamic.String.concat (list-to-array-internal separated [])))))
(doc print-doc "Print the documentation for a binding.")
(defmacro print-doc [name]
(eval (list 'macro-log (list 'meta name "doc"))))
(doc sig "Annotate a binding with the desired signature.")
(defmacro sig [name signature]
(eval (list 'meta-set! name "sig" signature)))
(doc print-sig "Print the annotated signature for a binding.")
(defmacro print-sig [name]
(eval (list 'macro-log (list 'meta name "sig"))))
(doc hidden "Mark a binding as hidden, this will make it not print with the 'info' command.")
(defmacro hidden [name]
(eval (list 'meta-set! name "hidden" true)))
(doc private "Mark a binding as private, this will make it inaccessible from other modules.")
(defmacro private [name]
(eval (list 'meta-set! name "private" true)))
(doc todo "sets the todo property for a binding.")
(defmacro todo [name value]
(eval (list 'meta-set! name "todo" value)))
(doc private? "Is this binding private?")
(defmacro private? [name]
(eval (list 'not (list 'list? (list 'meta name "private")))))
(doc hidden? "Is this binding hidden?")
(defmacro hidden? [name]
(eval (list 'not (list 'list? (list 'meta name "hidden")))))
(defndynamic annotate-helper [name annotation]
(list 'cons annotation (list 'meta name "annotations")))
(doc annotate "Add an annotation to this binding.")
(defmacro annotate [name annotation]
(eval (list 'meta-set! name "annotations" (eval (annotate-helper name annotation)))))
(doc deprecated "Declares that a binding is deprecated, using an optional explanation.")
(defmacro deprecated [name :rest explanation]
(let [v (if (= (length explanation) 0) true (car explanation))]
(eval (list 'meta-set! name "deprecated" v))))
(doc defn- "Declares a function while marking it as private and hidden.")
(defmacro defn- [name args form]
(do
(eval (list 'private name))
(eval (list 'hidden name))
(list 'defn name args form)))
(doc def- "Declares a variable while marking it as private and hidden.")
(defmacro def- [name value]
(do
(eval (list 'private name))
(eval (list 'hidden name))
(list 'def name value)))
(defndynamic cond-internal [xs]
(if (= (length xs) 0)
(list)
(if (= (length xs) 2)
(macro-error "cond has even number of branches; add an else branch")
(if (= (length xs) 1)
(car xs)
(list
'if
(car xs)
(cadr xs)
(cond-internal (cddr xs)))))))
(doc cond
"Executes a block of code if a specified condition is true. Multiple"
"such blocks can be chained."
""
"```"
"(cond"
" (< 10 1) (println \"Condition 1 is true\")"
" (> 10 1) (println \"Condition 2 is true\")"
" (println \"Else branch\"))"
"```")
(defmacro cond [:rest xs]
(cond-internal xs))
(defmacro refstr [x]
(list 'ref
(list 'str x)))
(defmacro swap! [x y]
(list 'let (array 'tmp y) (list 'do (list 'set! y x) (list 'set! x 'tmp))))
(defmacro update! [x f]
(list 'set! x (list f x)))
(defndynamic use-all-fn [names]
(if (= (length names) 0)
(macro-error "Trying to call use-all without arguments")
(do
(eval (list 'use (car names)))
(if (= (length names) 1)
()
(use-all-fn (cdr names))))))
(defmacro use-all [:rest names]
(use-all-fn names))
(defmacro load-and-use [name]
(do
(eval (list 'load (str name ".carp")))
(eval (list 'use name))))
(defmacro comment [:rest forms]
())
(defndynamic build-vararg [func forms]
(if (= (length forms) 0)
(macro-error "vararg macro needs at least one argument")
(if (= (length forms) 1)
(car forms)
(list func (car forms) (build-vararg func (cdr forms))))))
(defmacro and* [:rest forms]
(build-vararg 'and forms))
(defmacro or* [:rest forms]
(build-vararg 'or forms))
(defmacro ignore [form]
(list 'let (array '_ form) (list)))
(doc const-assert
"Asserts that the expression `expr` is true at compile time."
"Otherwise it will fail with the message `msg`."
""
"The expression must be evaluable at compile time.")
(defndynamic const-assert [expr msg]
(if expr () (macro-error msg)))
(doc defdynamic-once "Creates a dynamic variable and sets its value if it's not already defined.")
(defmacro defdynamic-once [var expr]
(eval
(list 'if (list 'defined? var)
()
(list 'defdynamic var expr))))
(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)))))
(deftemplate bottom (Fn [] a) "$a $NAME()" "$DECL { abort(); }")
(doc unreachable
"Asserts that a block of code will never be reached. If it is"
"the program will be aborted with an error message.")
(defmacro unreachable [msg]
(list 'do
(list 'IO.println
(list 'ref
(list 'fmt "%s:%d:%d: %s"
(eval (list 'file msg))
(eval (list 'line msg))
(eval (list 'column msg))
msg)))
(list 'System.abort)
(list 'bottom)))
(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 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)))
(defmodule Unsafe
(defmodule C
(defndynamic emit-c-line [append-strings args]
(let [strs (map (fn [x] (String.concat [x " "])) (map str args))
arr (collect-into strs array)
code (String.concat (append append-strings arr))]
(list 'Unsafe.preproc (list 'Unsafe.emit-c code))))
(doc pragma
"Emits a #pragma compiler directive in Carp's c output.")
(defmacro pragma [:rest args]
(eval (Unsafe.C.emit-c-line ["#pragma "] args)))
(doc define
"Emits a #define compiler directive in Carp's c output.")
(defmacro define [name value]
(Unsafe.C.emit-c-line ["#define "] [name value]))
(doc undef
"Emits a #undef compiler directive in Carp's c output.")
(defmacro undef [name]
(Unsafe.C.emit-c-line ["#undef "] [name]))
(defndynamic if- [if-pre name then else]
(do (eval (Unsafe.C.emit-c-line [if-pre] [name]))
(eval (Unsafe.C.emit-c-line [" "] [then]))
(if (not (empty? else))
(do (eval (Unsafe.C.emit-c-line ["#else"] []))
(eval (Unsafe.C.emit-c-line [" "] else)))
())
(eval (Unsafe.C.emit-c-line ["#endif"] []))))
(doc ifpre
"Emits a #if compiler directive in Carp's c output.")
(defmacro ifpre [name then :rest else]
(Unsafe.C.if- "#if " name then else))
(doc ifdef
"Emits a #ifdef compiler directive in Carp's c output.")
(defmacro ifdef [name then :rest else]
(Unsafe.C.if- "#ifdef " name then else))
(doc ifndef
"Emits a #ifndef compiler directive in Carp's c output.")
(defmacro ifndef [name then :rest else]
(Unsafe.C.if- "#ifndef " name then else))
(doc warning
"Emits a #warning compiler directive in Carp's c output.")
(defmacro warning [message]
(eval (Unsafe.C.emit-c-line ["#warning "] [message])))
(doc error
"Emits a #error compiler directive in Carp's c output.")
(defmacro error [message]
(eval (Unsafe.C.emit-c-line ["#error "] [message])))
(hidden asmify)
(defndynamic asmify [instruction]
(if (string? instruction)
(String.concat ["\"" instruction "\" "])
(str instruction)))
(doc asm
"Allows to define a named ASM construct. It allows both simple and "
"extended ASM."
""
"Example:"
"```"
"; exits with eit code 5, uses macOS syscalls"
"(Unsafe.C.asm exit5 \"mov $0x2000001, %rax\\n\" \"mov $5, %rdi\\n\" \"syscall\")"
""
"; writes from a variable called src into a variable dst and then adds 1 to dst"
"(Unsafe.C.asm addr \"mov %1, %0\\n\" \"add $1, %0\\n\" : \"=r\" (dst) : \"r\" (src))"
"```")
(defmacro asm [name :rest instructions]
(do
(eval (list 'Unsafe.C.define (String.concat [(str name) "()"])
(String.concat [
"__asm__("
(String.concat (collect-into (Dynamic.map Unsafe.C.asmify instructions) array))
");"])))
(eval (list 'register name '(Fn [] ())))))
)
)