From 44e752d7375258147f5341837f5be9d09171641c Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 4 Aug 2019 12:18:57 -0500 Subject: [PATCH] Add shorthand function literals to janet. These are similar to the function literals from Clojure (also Fennel), and should make short functions for maps, filters, etc. easier to write. --- CHANGELOG.md | 3 ++ src/boot/boot.janet | 94 +++++++++++++++++++++++++++++++++++---------- src/core/corelib.c | 29 ++++++++++++++ src/core/parse.c | 4 +- test/suite7.janet | 12 ++++++ tools/symcharsgen.c | 3 +- 6 files changed, 122 insertions(+), 23 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c491a41a..2e1b99ca 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,9 @@ All notable changes to this project will be documented in this file. ## Unreleased +- Add function literal short-hand via `|` reader macro, which maps to the + `short-fn` macro. +- Add `int?` and `nat?` functions to the core. - Add `(dyn :executable)` at top level to get what used to be `(process/args 0)`. - Add `:linux` to platforms returned by `(os/which)`. diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 2203e9a2..ff979e38 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -106,6 +106,7 @@ (defn false? "Check if x is false." [x] (= x false)) (defn nil? "Check if x is nil." [x] (= x nil)) (defn empty? "Check if xs is empty." [xs] (= 0 (length xs))) + (def idempotent? "(idempotent? x)\n\nCheck if x is a value that evaluates to itself when compiled." (do @@ -390,7 +391,7 @@ and object is any janet expression. The available verbs are:\n\n \t:iterate - repeatedly evaluate and bind to the expression while it is truthy.\n \t:range - loop over a range. The object should be two element tuple with a start - and end value, and an optional postive step. The range is half open, [start, end).\n + and end value, and an optional positive step. The range is half open, [start, end).\n \t:down - Same as range, but loops in reverse.\n \t:keys - Iterate over the keys in a data structure.\n \t:pairs - Iterate over the keys value pairs in a data structure.\n @@ -1290,14 +1291,21 @@ ### (defn macex1 - "Expand macros in a form, but do not recursively expand macros." - [x] + "Expand macros in a form, but do not recursively expand macros. + See macex docs for info on on-binding." + [x &opt on-binding] + + (when on-binding + (when (symbol? x) + (break (on-binding x)))) + + (defn recur [y] (macex1 y on-binding)) (defn dotable [t on-value] (def newt @{}) (var key (next t nil)) (while (not= nil key) - (put newt (macex1 key) (on-value (get t key))) + (put newt (recur key) (on-value (get t key))) (set key (next t key))) newt) @@ -1307,7 +1315,7 @@ :tuple (tuple/slice (map expand-bindings x)) :table (dotable x expand-bindings) :struct (table/to-struct (dotable x expand-bindings)) - (macex1 x))) + (recur x))) (defn expanddef [t] (def last (get t (- (length t) 1))) @@ -1316,20 +1324,20 @@ (array/concat @[(get t 0) (expand-bindings bound)] (tuple/slice t 2 -2) - @[(macex1 last)]))) + @[(recur last)]))) (defn expandall [t] - (def args (map macex1 (tuple/slice t 1))) + (def args (map recur (tuple/slice t 1))) (tuple (get t 0) ;args)) (defn expandfn [t] (def t1 (get t 1)) (if (symbol? t1) (do - (def args (map macex1 (tuple/slice t 3))) + (def args (map recur (tuple/slice t 3))) (tuple 'fn t1 (get t 2) ;args)) (do - (def args (map macex1 (tuple/slice t 2))) + (def args (map recur (tuple/slice t 2))) (tuple 'fn t1 ;args)))) (defn expandqq [t] @@ -1338,7 +1346,7 @@ :tuple (do (def x0 (get x 0)) (if (or (= 'unquote x0) (= 'unquote-splicing x0)) - (tuple x0 (macex1 (get x 1))) + (tuple x0 (recur (get x 1))) (tuple/slice (map qq x)))) :array (map qq x) :table (table (map qq (kvs x))) @@ -1366,16 +1374,16 @@ (cond s (s t) m? (m ;(tuple/slice t 1)) - (tuple/slice (map macex1 t)))) + (tuple/slice (map recur t)))) (def ret (case (type x) :tuple (if (= (tuple/type x) :brackets) - (tuple/brackets ;(map macex1 x)) + (tuple/brackets ;(map recur x)) (dotup x)) - :array (map macex1 x) - :struct (table/to-struct (dotable x macex1)) - :table (dotable x macex1) + :array (map recur x) + :struct (table/to-struct (dotable x recur)) + :table (dotable x recur) x)) ret) @@ -1415,18 +1423,64 @@ (not (deep-not= x y))) (defn macex - "Expand macros completely." - [x] + "Expand macros completely. + on-binding is an optional callback whenever a normal symbolic binding + is encounter. This allows macros to easily see all bindings use by their + arguments by calling macex on their contents. The binding itself is also + replaced by the value returned by on-binding within the expand macro." + [x &opt on-binding] (var previous x) - (var current (macex1 x)) + (var current (macex1 x on-binding)) (var counter 0) (while (deep-not= current previous) (if (> (++ counter) 200) (error "macro expansion too nested")) (set previous current) - (set current (macex1 current))) + (set current (macex1 current on-binding))) current) +### +### +### Function shorthand +### +### + +(defmacro short-fn + "fn shorthand.\n\n + usage:\n\n + \t(short-fn (+ $ $)) - A function that double's its arguments.\n + \t(short-fn (string $0 $1)) - accepting multiple args\n + \t|(+ $ $) - use pipe reader macro for terse function literals\n + \t|(+ $&) - variadic functions" + [arg] + (var max-param-seen -1) + (var vararg false) + (defn saw-special-arg + [num] + (set max-param-seen (max max-param-seen num))) + (defn on-binding + [x] + (if (string/has-prefix? '$ x) + (cond + (= '$ x) + (do + (saw-special-arg 0) + '$0) + (= '$& x) + (do + (set vararg true) + x) + :else + (do + (def num (scan-number (string/slice x 1))) + (if (nat? num) + (saw-special-arg num)) + x)) + x)) + (def expanded (macex arg on-binding)) + (def fn-args (seq [i :range [0 (+ 1 max-param-seen)]] (symbol '$ i))) + ~(fn [,;fn-args ,;(if vararg ['& '$&] [])] ,expanded)) + ### ### ### Evaluation and Compilation @@ -1474,7 +1528,7 @@ :env - the environment to compile against - default is the current env\n\t :source - string path of source for better errors - default is \"\"\n\t :on-compile-error - callback when compilation fails - default is bad-compile\n\t - :compile-only - only compile the souce, do not execute it - default is false\n\t + :compile-only - only compile the source, do not execute it - default is false\n\t :on-status - callback when a value is evaluated - default is debug/stacktrace\n\t :fiber-flags - what flags to wrap the compilation fiber with. Default is :ia." [opts] diff --git a/src/core/corelib.c b/src/core/corelib.c index 07351d8d..12533f44 100644 --- a/src/core/corelib.c +++ b/src/core/corelib.c @@ -22,6 +22,7 @@ #ifndef JANET_AMALG #include +#include #include "compile.h" #include "state.h" #include "util.h" @@ -459,6 +460,24 @@ static Janet janet_core_untrace(int32_t argc, Janet *argv) { return argv[0]; } +static Janet janet_core_check_int(int32_t argc, Janet *argv) { + janet_fixarity(argc, 1); + if (!janet_checktype(argv[0], JANET_NUMBER)) goto ret_false; + double num = janet_unwrap_number(argv[0]); + return janet_wrap_boolean(num == (double)((int32_t)num)); +ret_false: + return janet_wrap_false(); +} + +static Janet janet_core_check_nat(int32_t argc, Janet *argv) { + janet_fixarity(argc, 1); + if (!janet_checktype(argv[0], JANET_NUMBER)) goto ret_false; + double num = janet_unwrap_number(argv[0]); + return janet_wrap_boolean(num >= 0 && (num == (double)((int32_t)num))); +ret_false: + return janet_wrap_false(); +} + static const JanetReg corelib_cfuns[] = { { "native", janet_core_native, @@ -636,6 +655,16 @@ static const JanetReg corelib_cfuns[] = { "to expand the path to a path that can be " "used for importing files.") }, + { + "int?", janet_core_check_int, + JDOC("(int? x)\n\n" + "Check if x can be exactly represented as a 32 bit signed two's complement integer.") + }, + { + "nat?", janet_core_check_nat, + JDOC("(nat? x)\n\n" + "Check if x can be exactly represented as a non-negative 32 bit signed two's complement integer.") + }, {NULL, NULL, NULL} }; diff --git a/src/core/parse.c b/src/core/parse.c index 429aaaec..e19bff42 100644 --- a/src/core/parse.c +++ b/src/core/parse.c @@ -42,7 +42,7 @@ static int is_whitespace(uint8_t c) { * if not. The upper characters are also considered symbol * chars and are then checked for utf-8 compliance. */ static const uint32_t symchars[8] = { - 0x00000000, 0xf7ffec72, 0xc7ffffff, 0x17fffffe, + 0x00000000, 0xf7ffec72, 0xc7ffffff, 0x07fffffe, 0xffffffff, 0xffffffff, 0xffffffff, 0xffffffff }; @@ -179,6 +179,7 @@ static void popstate(JanetParser *p, Janet val) { (c == '\'') ? "quote" : (c == ',') ? "unquote" : (c == ';') ? "splice" : + (c == '|') ? "short-fn" : (c == '~') ? "quasiquote" : ""; t[0] = janet_csymbolv(which); t[1] = val; @@ -492,6 +493,7 @@ static int root(JanetParser *p, JanetParseState *state, uint8_t c) { case ',': case ';': case '~': + case '|': pushstate(p, root, PFLAG_READERMAC | c); return 1; case '"': diff --git a/test/suite7.janet b/test/suite7.janet index 406a0034..749d566e 100644 --- a/test/suite7.janet +++ b/test/suite7.janet @@ -144,4 +144,16 @@ (assert (= 15 ((comp inc inc inc inc inc +) 1 2 3 4)) "variadic comp 6") (assert (= 16 ((comp inc inc inc inc inc inc +) 1 2 3 4)) "variadic comp 7") +# Function shorthand +(assert (= (|(+ 1 2 3)) 6) "function shorthand 1") +(assert (= (|(+ 1 2 3 $) 4) 10) "function shorthand 2") +(assert (= (|(+ 1 2 3 $0) 4) 10) "function shorthand 3") +(assert (= (|(+ $0 $0 $0 $0) 4) 16) "function shorthand 4") +(assert (= (|(+ $ $ $ $) 4) 16) "function shorthand 5") +(assert (= (|4) 4) "function shorthand 6") +(assert (= (((|||4))) 4) "function shorthand 7") +(assert (= (|(+ $1 $1 $1 $1) 2 4) 16) "function shorthand 8") +(assert (= (|(+ $0 $1 $3 $2 $6) 0 1 2 3 4 5 6) 12) "function shorthand 9") + + (end-suite) diff --git a/tools/symcharsgen.c b/tools/symcharsgen.c index 92fcb83f..4e28f023 100644 --- a/tools/symcharsgen.c +++ b/tools/symcharsgen.c @@ -44,8 +44,7 @@ static int is_symbol_char_gen(uint8_t c) { c == '>' || c == '@' || c == '^' || - c == '_' || - c == '|'); + c == '_'); } int main() {