From 52c919d96fd4315bbf7d54c4d2a49a7f466d21fc Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Fri, 30 Nov 2018 01:58:52 -0500 Subject: [PATCH] Add qq (, uq and uqs) for a quasiquote macro. quasiquoting is not (yet) supported as a special form and has no syntactic sugar. --- Makefile | 2 -- README.md | 4 ++-- src/core/core.janet | 33 +++++++++++++++++++++++------- test/suite3.janet | 50 --------------------------------------------- 4 files changed, 28 insertions(+), 61 deletions(-) delete mode 100644 test/suite3.janet diff --git a/Makefile b/Makefile index 96b8b431..c6074ff4 100644 --- a/Makefile +++ b/Makefile @@ -160,7 +160,6 @@ test: $(JANET_TARGET) $(TEST_PROGRAMS) ./$(JANET_TARGET) test/suite0.janet ./$(JANET_TARGET) test/suite1.janet ./$(JANET_TARGET) test/suite2.janet - ./$(JANET_TARGET) test/suite3.janet valtest: $(JANET_TARGET) $(TEST_PROGRAMS) valgrind --leak-check=full -v ctest/system_test.out @@ -170,7 +169,6 @@ valtest: $(JANET_TARGET) $(TEST_PROGRAMS) valgrind --leak-check=full -v ./$(JANET_TARGET) test/suite0.janet valgrind --leak-check=full -v ./$(JANET_TARGET) test/suite1.janet valgrind --leak-check=full -v ./$(JANET_TARGET) test/suite2.janet - valgrind --leak-check=full -v ./$(JANET_TARGET) test/suite3.janet ################### ##### Natives ##### diff --git a/README.md b/README.md index 9dfc632b..60219fc4 100644 --- a/README.md +++ b/README.md @@ -30,7 +30,7 @@ Janet makes a good system scripting language, or a language to embed in other pr * First class closures * Garbage collection * First class green threads (continuations) -* Python style generators +* Python style generators (implemented as a plain macro) * Mutable and immutable arrays (array/tuple) * Mutable and immutable hashtables (table/struct) * Mutable and immutable strings (buffer/string) @@ -43,7 +43,7 @@ Janet makes a good system scripting language, or a language to embed in other pr * Lexical scoping * Imperative programming as well as functional * REPL -* 300+ functions in the core library + * 300+ functions and macros in the core library * Interactive environment with detailed stack traces ## Documentation diff --git a/src/core/core.janet b/src/core/core.janet index bbd13c8f..97bde3a3 100644 --- a/src/core/core.janet +++ b/src/core/core.janet @@ -776,7 +776,6 @@ value, one key will be ignored." (put res keys@i vals@i)) res) - (defn update "Accepts a key argument and passes its' associated value to a function. The key then, is associated to the function's return value" @@ -999,14 +998,14 @@ value, one key will be ignored." x)) ret) -(defn all? [xs] +(defn all? [pred xs] (var good true) - (loop [x :in xs :while good] (if x nil (:= good false))) + (loop [x :in xs :while good] (if (pred x) nil (:= good false))) good) -(defn some? [xs] +(defn some? [pred xs] (var bad true) - (loop [x :in xs :while bad] (if x (:= bad false))) + (loop [x :in xs :while bad] (if (pred x) (:= bad false))) (not bad)) (defn deep-not= [x y] @@ -1016,8 +1015,8 @@ value, one key will be ignored." (or (not= tx (type y)) (case tx - :tuple (or (not= (length x) (length y)) (some? (map deep-not= x y))) - :array (or (not= (length x) (length y)) (some? (map deep-not= x y))) + :tuple (or (not= (length x) (length y)) (some? identity (map deep-not= x y))) + :array (or (not= (length x) (length y)) (some? identity (map deep-not= x y))) :struct (deep-not= (pairs x) (pairs y)) :table (deep-not= (table.to-struct x) (table.to-struct y)) :buffer (not= (string x) (string y)) @@ -1333,3 +1332,23 @@ value, one key will be ignored." k :keys envi] (:= symbol-set@k true)) (sort (keys symbol-set))) + +(defmacro qq + "Quasiquote." + [x] + (defn- uqs? [x] + (and (tuple? x) (= x@0 'uqs))) + (defn- uqs [x] + (if (uqs? x) + (tuple apply array x@1) + @[(qq x)])) + (case (type x) + :symbol (tuple 'quote x) + :tuple (cond + (= x@0 'uq) x@1 + (some? uqs? x) (tuple tuple.slice (tuple.prepend (map uqs x) array.concat)) + (apply tuple tuple (map qq x))) + :array (apply array (map qq x)) + :struct (apply struct (interleave (map qq (keys x)) (map qq (values x)))) + :table (apply table (interleave (map qq (keys x)) (map qq (values x)))) + x)) diff --git a/test/suite3.janet b/test/suite3.janet deleted file mode 100644 index 68b4ed3e..00000000 --- a/test/suite3.janet +++ /dev/null @@ -1,50 +0,0 @@ -# Copyright (c) 2018 Calvin Rose -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -# IN THE SOFTWARE. - -(import test.helper :prefix "" :exit true) -(start-suite 3) - -# Class stuff -(defclass Car) - -(defnew Car - "Make a new car." - [color] - (put self :color color)) - -(defm Car:honk - "Honk the horn." - [] - (string "Honk! from a " (get self :color) " car!")) - -(def redcar (Car:new :red)) -(def greencar (Car:new :green)) - -(assert (= (call redcar:honk) ($ redcar:honk)) "$ alias for call 1") -(assert (= (call greencar:honk) ($ greencar:honk)) "$ alias for call 2") - -(assert (= (call redcar:honk) "Honk! from a :red car!") "method call 1") -(assert (= (call greencar:honk) "Honk! from a :green car!") "method call 2") - -(def wrapper (wrap-call redcar:honk)) -(assert (= (call redcar:honk) (wrapper)) "wrap-call") - -(end-suite) -