├── .gitignore ├── tests ├── clamp-suite.lisp ├── lisp1-suite.lisp ├── io-suite.lisp ├── macros-suite.lisp ├── memoize-suite.lisp ├── clamp-experimental-suite.lisp ├── fns-suite.lisp ├── coerce-suite.lisp ├── destructuring-suite.lisp ├── binding-suite.lisp ├── read-suite.lisp ├── setforms-suite.lisp ├── base-suite.lisp ├── fnops-suite.lisp ├── ssyntax-suite.lisp ├── sort-suite.lisp ├── strings-suite.lisp ├── print-suite.lisp ├── misc-suite.lisp ├── tables-suite.lisp ├── iter-suite.lisp ├── conditionals-suite.lisp ├── list-suite.lisp └── hof-suite.lisp ├── sbclinit ├── src ├── syntax.lisp ├── memoize.lisp ├── fns.lisp ├── code.lisp ├── disk.lisp ├── base.lisp ├── io.lisp ├── time.lisp ├── binding.lisp ├── defalias.lisp ├── read.lisp ├── aliases.lisp ├── sort.lisp ├── setforms.lisp ├── tables.lisp ├── iter.lisp ├── strings.lisp ├── print.lisp ├── deftem.lisp ├── fnops.lisp ├── macros.lisp ├── hof.lisp ├── misc.lisp ├── conditionals.lisp ├── list.lisp └── package.lisp ├── clamp ├── experimental ├── package.lisp ├── coerce.lisp ├── def.lisp ├── lisp1.lisp ├── ssyntax-defs.lisp ├── destructuring.lisp └── ssyntax.lisp ├── clamp-experimental.asd ├── clamp-tests.asd ├── clamp.asd ├── Readme.md └── LICENSE /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl -------------------------------------------------------------------------------- /tests/clamp-suite.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :clamp-tests 2 | (:use :clamp :clunit :check-it) 3 | (:import-from :syntax :use-syntax)) 4 | 5 | (in-package :clamp-tests) 6 | 7 | (defsuite clamp ()) 8 | -------------------------------------------------------------------------------- /sbclinit: -------------------------------------------------------------------------------- 1 | ;; startup file for SBCL to load Clamp. Use it like this: 2 | ;; $ sbcl --sysinit sbclinit 3 | 4 | (load "~/quicklisp/setup.lisp") 5 | (ql:quickload :clamp) 6 | (in-package :clamp) 7 | (use-syntax :clamp) 8 | -------------------------------------------------------------------------------- /tests/lisp1-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :experimental-tests) 2 | (use-syntax :clamp) 3 | 4 | (deftest lisp1 (clamp-experimental) 5 | (assert-equal '((1 4) (2 5) (3 6)) 6 | (w/lisp1 (map list '(1 2 3) '(4 5 6)))) 7 | (assert-equal '((1 4) (2 5) (3 6)) 8 | (w/lisp1 (let var list 9 | (map var '(1 2 3) '(4 5 6)))))) 10 | -------------------------------------------------------------------------------- /tests/io-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite io (clamp)) 5 | 6 | (deftest allchars (io) 7 | (w/instring in "hello goodbye" 8 | (assert-equalp "hello goodbye" (allchars in))) 9 | (w/instring in (tostring (prf "hello~%goodbye~%")) 10 | (assert-equalp (tostring (prf "hello~%goodbye~%")) (allchars in)))) 11 | -------------------------------------------------------------------------------- /tests/macros-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite macros (clamp)) 5 | 6 | (deftest mkstr (macros) 7 | (assert-equalp "AbcDE5" (mkstr 'a "bc" 'de 5)) 8 | (assert-equalp "AbcDE5" (mkstr #\A "bc" 'de "5"))) 9 | 10 | (deftest symb (macros) 11 | (assert-eq '|AbcDE5| (symb 'a "bc" 'de 5)) 12 | (assert-eq '|AbcDE5| (symb #\A "bc" 'de "5"))) 13 | -------------------------------------------------------------------------------- /tests/memoize-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite memoize (clamp)) 5 | 6 | (deftest defmemo (memoize) 7 | (defmemo fib (n) 8 | (if (<= 0 n 1) 9 | n 10 | (+ (fib (- n 1)) 11 | (fib (- n 2))))) 12 | ;; We know defmemo works if this ever finishes with the answer. 13 | (assert-eql 354224848179261915075 (fib 100))) 14 | -------------------------------------------------------------------------------- /tests/clamp-experimental-suite.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :clamp-experimental-tests 2 | (:use :clunit :clamp :clamp-experimental) 3 | (:import-from :syntax :use-syntax) 4 | (:nicknames :experimental-tests) 5 | (:shadowing-import-from :clamp-experimental 6 | :def :defmemo :defmethod :mac :fn :coerce)) 7 | 8 | (in-package :clamp-experimental-tests) 9 | 10 | (defsuite clamp-experimental ()) 11 | -------------------------------------------------------------------------------- /src/syntax.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp) 2 | 3 | (define-package-syntax :clamp 4 | (:merge :standard) 5 | (:macro-char #\] (get-macro-character #\))) 6 | (:macro-char #\[ (lambda (stream char) 7 | (declare (ignore char)) 8 | `(lambda (_) 9 | (declare (ignorable _)) 10 | (,@(read-delimited-list #\] stream t)))))) 11 | -------------------------------------------------------------------------------- /tests/fns-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite fns (clamp)) 5 | 6 | (deftest rfn (fns) 7 | (let f (rfn fib (n) 8 | (if (<= 0 n 1) 9 | n 10 | (+ (fib (- n 1)) 11 | (fib (- n 2))))) 12 | (assert-eql 55 (call f 10)) 13 | (assert-eql 34 (call f 9)))) 14 | 15 | (deftest afn (fns) 16 | (let f (afn (n) 17 | (if (<= 0 n 1) 18 | n 19 | (+ (self (- n 1)) 20 | (self (- n 2))))) 21 | (assert-eql 55 (call f 10)) 22 | (assert-eql 34 (call f 9)))) 23 | -------------------------------------------------------------------------------- /clamp: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Start Clamp with a single command. 3 | # 4 | # Currently works only on Linux with SBCL+Quicklisp. 5 | # Requires the Clamp repo to be at ~/quicklisp/local-projects/Clamp. 6 | 7 | if [ ! -d ~/quicklisp/local-projects/Clamp ] 8 | then 9 | echo "Clamp repo not found. Please install Quicklisp and make sure you clone Clamp at ~/quicklisp/local-projects/Clamp" 10 | exit 1 11 | fi 12 | 13 | if which rlwrap >&/dev/null 14 | then 15 | RLWRAP='rlwrap --complete-filenames --quote-character "\"" --remember --break-chars "[]()!:~\"" -C clamp' 16 | fi 17 | 18 | $RLWRAP sbcl --sysinit ~/quicklisp/local-projects/Clamp/sbclinit 19 | -------------------------------------------------------------------------------- /experimental/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :clamp-experimental 2 | (:nicknames :experimental) 3 | (:use :clamp) 4 | (:shadow :coerce :def :defmethod :fn :mac :defmemo) 5 | (:import-from :syntax :use-syntax) 6 | (:export 7 | ;; From ssyntax. 8 | :w/ssyntax :defssyntax-test :defssyntax-macro :defssyntax-sym-mac 9 | 10 | ;; From destructuring. 11 | :fn :! :? 12 | 13 | ;; From coerce. 14 | :coerce :defcoerce 15 | 16 | ;; From lisp1. 17 | :w/lisp1 18 | 19 | ;; From def. 20 | :def :defmemo :defmethod :mac)) 21 | 22 | ;;;; There must be someway to export all of the symbols in clamp 23 | ;;;; except for desired symbols. 24 | -------------------------------------------------------------------------------- /src/memoize.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are utilities for taking advantage of memoization. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (def memo (f) 7 | "Returns a memoized version of the procedure F." 8 | (let cache (table :test #'iso) 9 | (fn (&rest args) 10 | (or2= (gethash args cache) (apply f args))))) 11 | 12 | (mac defmemo (name args &body body) 13 | "Defines a memoized procedure." 14 | `(eval-when (:compile-toplevel :load-toplevel :execute) 15 | (declaim (ftype (function (&rest t) t) ,name)) 16 | (= (symbol-function ',name) (memo (fn ,args (block ,name ,@body)))) 17 | ,(when (stringp (car body)) 18 | `(= (documentation ',name 'function) ,(car body))) 19 | ',name)) 20 | -------------------------------------------------------------------------------- /tests/coerce-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-experimental-tests) 2 | (use-syntax :clamp) 3 | 4 | (deftest table->list (clamp-experimental) 5 | ;; The results need to be sorted. Otherwise the order of the elements is undefined. 6 | (assert-equal '((1 2) (3 4) (5 6)) (sort #'< (coerce (obj 1 2 3 4 5 6) 'list) #'car)) 7 | (assert-equal '((a 1) (b 2) (c 3)) (sort #'< (coerce (obj a 1 b 2 c 3) 'list) #'cadr))) 8 | 9 | (deftest list->table (clamp-experimental) 10 | ;; The macro obj cannot be used here. Otherwise the tables would have different :tests. 11 | (assert-equalp (listtab '((1 2) (3 4) (5 6))) (coerce '((1 2) (3 4) (5 6)) 'hash-table)) 12 | (assert-equalp (listtab '((a 1) (b 2) (c 3))) (coerce '((a 1) (b 2) (c 3)) 'hash-table))) 13 | -------------------------------------------------------------------------------- /experimental/coerce.lisp: -------------------------------------------------------------------------------- 1 | ;;;; This is an experimental implementation of customizable coercion. 2 | 3 | (in-package :experimental) 4 | (use-syntax :clamp) 5 | 6 | (defgeneric coerce (obj to) 7 | (:documentation "Coerces OBJ to type TO.")) 8 | 9 | (cl:defmethod coerce (obj to) 10 | "Default to cl:coerce." 11 | (cl:coerce obj to)) 12 | 13 | (defmacro defcoerce (from to args &body body) 14 | "Defines a coercer from type FROM to type TO. ARGS is a list of 15 | arguments needed for the coercion, so far only one argument is 16 | supported." 17 | `(cl:defmethod coerce ((,(car args) ,from) (,(uniq) (eql ',to))) 18 | ,@body)) 19 | 20 | (defcoerce hash-table list (tab) 21 | "Coerce from hash-table to list." 22 | (tablist tab)) 23 | 24 | (defcoerce list hash-table (xs) 25 | "Coerce from list to hash-table." 26 | (listtab xs)) 27 | -------------------------------------------------------------------------------- /src/fns.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are macros which allow for creation of procedures. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (mac rfn (name parms &body body) 7 | "Creates a recursive procedure which can refer to itself through 8 | NAME." 9 | `(labels ((,name ,parms ,@body)) 10 | #',name)) 11 | 12 | (mac afn (parms &body body) 13 | "Creates a recursive procedure which can refer to itself through 14 | the symbol 'self'." 15 | `(rfn self ,parms ,@body)) 16 | 17 | (mac rec (withses &body body) 18 | "Bind the WITHSES and execute BODY. Using 'recur' allows a 19 | recursive 'jump' to the top of the body with the new bindings 20 | passed into recur. This is very similar to loop in clojure, 21 | but this allows multiple recursive calls." 22 | (let w (pair withses) 23 | `(call (rfn recur ,(map #'car w) ,@body) ,@(map #'cadr w)))) 24 | -------------------------------------------------------------------------------- /src/code.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Utilities for generating statistics for code. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (def codelines (file) 7 | "Counts the number of non-blank, non-comment lines in a file." 8 | (w/infile in file 9 | (summing test 10 | (whilet line (read-line :from in :eof nil) 11 | (test (aand (find #'nonwhite line) 12 | (not (is it #\;)))))))) 13 | 14 | (def codeflat (file) 15 | "Returns the number of atoms (excluding nil) in the file." 16 | (w/infile in file 17 | (len (flat (readall :from in))))) 18 | 19 | (def tokcount (files) 20 | "Counts the number of times every atom (excluding nil) occurs in 21 | the given list of files." 22 | (ret counts (table) 23 | (each f files 24 | (w/infile in f 25 | (each token (flat (readall :from in)) 26 | (++ (gethash token counts 0))))))) 27 | -------------------------------------------------------------------------------- /experimental/def.lisp: -------------------------------------------------------------------------------- 1 | (in-package :experimental) 2 | (use-syntax :clamp) 3 | 4 | (defmacro defexperimental (new old) 5 | "Defines a definition special form, NEW, which is the same as the 6 | definition special form, OLD, except it allows for ssyntax, 7 | and the new argument lists." 8 | `(defmacro ,new (name args &body body) 9 | `(w/ssyntax 10 | ,(mvb (new-args alist) (parse-args args) 11 | (if (null alist) 12 | `(,',old ,name ,new-args ,@body) 13 | `(,',old ,name ,new-args 14 | (let ,(map #'cadr alist) (list ,@(map #'car alist)) 15 | ,@body))))))) 16 | 17 | (defexperimental def clamp:def) 18 | (defexperimental defmemo clamp:defmemo) 19 | (defexperimental mac clamp:mac) 20 | 21 | (mac defmethod (name args &body body) 22 | "Version of defmethod that allows for ssyntax." 23 | `(w/ssyntax (cl:defmethod ,name ,args ,@body))) 24 | -------------------------------------------------------------------------------- /tests/destructuring-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :experimental-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite destructuring (clamp-experimental)) 5 | 6 | (deftest regular (destructuring) 7 | (let f (fn fn fn) 8 | (assert-equal '() (call f)) 9 | (assert-equal '(1 2 3) (call f 1 2 3))) 10 | (let f (fn ((x . y)) (join x y)) 11 | (assert-equal '(1 2 3 4) (call f '((1 2) 3 4))) 12 | (assert-equal '(1) (call f '((1))))) 13 | (let f (fn ((a b) (c . d) e) (list a b c d e)) 14 | (assert-equal '(1 2 3 4 5) (call f '(1 2) '(3 . 4) 5)) 15 | (assert-equal '(1 2 3 (4 5) 6) (call f '(1 2) '(3 4 5) 6))) 16 | (let f (fn (a b c . d) (list a b c d)) 17 | (assert-equal '(1 2 3 (4 5)) (call f 1 2 3 4 5)))) 18 | 19 | (deftest optional (clamp-experimental) 20 | (let f (fn (a (b c) &optional ((d e) '(1 2))) (list a b c d e)) 21 | (assert-equal '(1 2 3 1 2) (call f 1 '(2 3))) 22 | (assert-equal '(1 2 3 4 5) (call f 1 '(2 3) '(4 5))))) 23 | -------------------------------------------------------------------------------- /experimental/lisp1.lisp: -------------------------------------------------------------------------------- 1 | (in-package :experimental) 2 | (use-syntax :clamp) 3 | 4 | ;; The macro w/lisp1 works by defining every symbol within the body to 5 | ;; expand into itself surrounded by a call to function. The symbol 6 | ;; will not be expanded again since function is a special form. Due to 7 | ;; the fact that symbol-macrolet is lexically scoped, it is still 8 | ;; possible to define variables within the w/lisp1 form, although it 9 | ;; is impossible to refer to symbols outside of it. You cannot use any 10 | ;; symbol that is defined as a global variable within the w/lisp1, 11 | ;; because it is an error to define a symbol-macrolet with the same 12 | ;; name as a global variable. It is currently not possible to call 13 | ;; variables as procedures. 14 | 15 | (defmacro w/lisp1 (&rest body) 16 | "Evaluate BODY as if in a lisp-1." 17 | `(symbol-macrolet ,(mapeach sym (redup (keep #'symbolp (flat body))) 18 | `(,sym #',sym)) 19 | ,@body)) 20 | -------------------------------------------------------------------------------- /clamp-experimental.asd: -------------------------------------------------------------------------------- 1 | (in-package :asdf-user) 2 | 3 | ;;;; This is a system only for the experimental features of Clamp. If 4 | ;;;; you want both the experimental features and the normal ones, you 5 | ;;;; will have to require both and handle the conflicts. 6 | 7 | (defsystem "clamp-experimental" 8 | :description "The experimental features of CLAMP" 9 | :version "0.1" 10 | :author "malisper" 11 | :depends-on ("clamp") 12 | :components ((:module "experimental" 13 | :components ((:file "package") 14 | (:file "destructuring" :depends-on ("package")) 15 | (:file "ssyntax" :depends-on ("package" "destructuring")) 16 | (:file "ssyntax-defs" :depends-on ("ssyntax")) 17 | (:file "coerce" :depends-on ("package")) 18 | (:file "lisp1" :depends-on ("package")) 19 | (:file "def" :depends-on ("ssyntax" "destructuring")))))) 20 | -------------------------------------------------------------------------------- /src/disk.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp) 2 | (use-syntax :clamp) 3 | 4 | (defvar savers* (table) "A table containing the save functions.") 5 | 6 | (mac fromdisk (var file init load save) 7 | "Define a variable which if unbound, its value will be taken from 8 | FILE if it exists. If it does not exist, it is found by calling 9 | LOAD on the file. The variable can be saved by calling todisk 10 | which will save it using SAVE." 11 | (w/uniq (gf gv) 12 | `(defvar ,var (do1 (iflet ,gf (file-exists ,file) 13 | (call ,load ,gf) 14 | ,init) 15 | (= (gethash ',var savers*) 16 | (fn (,gv) 17 | (call ,save ,gv ,file))))))) 18 | 19 | (mac diskvar (var file) 20 | "Creates a variable whose value will come from FILE." 21 | `(fromdisk ,var ,file nil #'readfile1 #'writefile)) 22 | 23 | (mac todisk (var &optional (expr var)) 24 | "Saves the value of VAR according to its value in savers*." 25 | `(call (gethash ',var savers*) 26 | ,(if (is var expr) 27 | var 28 | `(= ,var ,expr)))) 29 | -------------------------------------------------------------------------------- /tests/binding-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite binding (clamp)) 5 | 6 | (deftest with (binding) 7 | (assert-eql 6 (with (a 1 b 2 c 3) (+ a b c))) 8 | (assert-eql 6 (with ((x y) (list 1 2) z 3) (+ x y z))) 9 | (assert-equal '(2 1) 10 | (with (a 1 b 2) (with (a b b a) (list a b))))) 11 | 12 | (deftest let (binding) 13 | (assert-expands (with (a b) c) (let a b c)) 14 | (assert-eql 8 (let x 3 (+ x 5))) 15 | (assert-eql 3 (let (x . y) (cons 1 2) (+ x y)))) 16 | 17 | (deftest ret (binding) 18 | (assert-eql 15 (ret x 5 (incf x 10) nil)) 19 | (assert-equal '(a b) (ret x '() (push 'b x) (push 'a x) nil))) 20 | 21 | (deftest rets (binding) 22 | (assert-equal '() (mvl (rets () 10))) 23 | (assert-equal '(5 10) (mvl (rets (x 0 y 0) (++ x 5) (++ y 10))))) 24 | 25 | (deftest rets1 (binding) 26 | (assert-equal '(nil) (mvl (rets1 () 10))) 27 | (assert-equal '(5) (mvl (rets1 (x 0 y 0) (++ x 5) (++ y 10))))) 28 | 29 | (deftest flet1 (binding) 30 | (assert-expands (flet ((a (x y z) b))) (flet1 a (x y z) b))) 31 | 32 | (deftest withs (binding) 33 | (assert-eql 12 (withs (x 5 y (+ x 3)) (+ y 4)))) 34 | -------------------------------------------------------------------------------- /tests/read-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite read (clamp)) 5 | 6 | (deftest readc (read) 7 | (fromstring "hello" 8 | (assert-eql #\h (readc)) 9 | (assert-eql #\e (readc)) 10 | (assert-eql #\l (readc)) 11 | (w/instring in "world" 12 | (assert-eql #\l (readc)) 13 | (assert-eql #\w (readc :from in)) 14 | (assert-eql #\o (readc :from in)) 15 | (assert-eql #\o (readc)) 16 | (assert-eql #\r (readc :from in)) 17 | (assert-eql #\l (readc :from in)) 18 | (assert-eql #\d (readc :from in))) 19 | (assert-eql '() (readc :eof nil)))) 20 | 21 | (deftest peekc (read) 22 | (fromstring "hello" 23 | (assert-eql #\h (peekc)) 24 | (assert-eql #\h (peekc)) 25 | (w/instring in "world" 26 | (assert-eql #\h (peekc)) 27 | (assert-eql #\w (peekc :from in)) 28 | (assert-eql #\w (peekc :from in))))) 29 | 30 | (deftest read (read) 31 | (fromstring "(1 2 3 4)5" 32 | (assert-equal '(1 2 3 4) (read)) 33 | (w/instring in "hello 6" 34 | (assert-eq 'hello (read :from in)) 35 | (assert-eql 5 (read)) 36 | (assert-eql 6 (read :from in)) 37 | (assert-eql nil (read :eof nil))))) 38 | -------------------------------------------------------------------------------- /tests/setforms-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite setforms (clamp)) 5 | 6 | (deftest zap (setforms) 7 | (assert-eql 100 (ret x 10 (zap [* _ _] x))) 8 | (assert-equal (range 1 10) 9 | (ret x (range 1 5) 10 | (zap #'append x (range 6 10))))) 11 | 12 | (deftest or= (setforms) 13 | (let x nil 14 | (assert-eql 5 (or= x 5)) 15 | (assert-eql 5 (or= x 7))) 16 | ;; This is for the problem or2= is supposed to fix. 17 | (let tab (table) 18 | (assert-eql nil (or= (gethash 'a tab) nil)) 19 | (assert-eql 5 (or= (gethash 'a tab) 5)))) 20 | 21 | (deftest or2= (setforms) 22 | (let tab (table) 23 | (assert-eql 5 (or2= (gethash 'a tab) 5)) 24 | (assert-eql 5 (or2= (gethash 'a tab) 7)) 25 | (assert-eql nil (or2= (gethash 'b tab) nil)) 26 | (assert-eql nil (or2= (gethash 'b tab) 5)))) 27 | 28 | (deftest set (setforms) 29 | (let x nil 30 | (set x) 31 | (assert-true x)) 32 | (with (x 5 y (list 1 2 3)) 33 | (set x (car y) (cadr y)) 34 | (assert-equal '(t t t 3) (cons x y)))) 35 | 36 | (deftest wipe (setforms) 37 | (let x nil 38 | (wipe x) 39 | (assert-false x)) 40 | (with (x 5 y (list 1 2 3)) 41 | (wipe x (car y) (cadr y)) 42 | (assert-equal '(nil nil nil 3) (cons x y)))) 43 | -------------------------------------------------------------------------------- /src/base.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are some basic utilities which need to be loaded first. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (def map (f seq &rest seqs) 7 | "Maps F over the sequences. The returned sequence will always be of 8 | type list." 9 | (apply #'cl:map 'list f seq seqs)) 10 | 11 | ;;; This cannot be defined as an alias because then it would expand 12 | ;;; into #'(fn ..) which is an error. 13 | (mac fn (args &body body) 14 | "Equivalent to lambda except this cannot be used as the name of 15 | of a procedure (ie ((fn ..) ..))." 16 | `(lambda ,args ,@body)) 17 | 18 | (def single (xs) 19 | "Does this list have one and only one element?" 20 | (and (consp xs) (no (cdr xs)))) 21 | 22 | (def pair (xs) 23 | "Applies F to every two elements of xs and collects the results." 24 | (cond ((no xs) '()) 25 | ((single xs) (list (list (car xs)))) 26 | (:else (cons (list (car xs) (cadr xs)) 27 | (pair (cddr xs)))))) 28 | 29 | (mac if (&rest clauses) 30 | "Equivalent to cond, but does not require parens parens around each 31 | individual clause." 32 | ;; For some reason, SBCL deduces that the value of the cond can be 33 | ;; nil when there is only a return value for the else clause of a 34 | ;; cond (cond .. (x)). Because of this the else clause is explicit 35 | ;; about the last value so that SBCL doesn't freak out. 36 | (cl:if (even (len clauses)) 37 | `(cond ,@(pair clauses)) 38 | `(cond ,@(pair (butlast clauses)) ,(cons t (lastcons clauses))))) 39 | -------------------------------------------------------------------------------- /tests/base-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite base (clamp)) 5 | 6 | (deftest map (base) 7 | (assert-true 8 | (check-it (generator (list (integer))) 9 | (lambda (xs) 10 | (is (len xs) (len (map [* _ _] xs)))))) 11 | (assert-true 12 | (check-it (generator (list (integer))) 13 | (lambda (xs) 14 | (every (fn (x y) 15 | (is (* x x) y)) 16 | xs 17 | (map [* _ _] xs)))))) 18 | 19 | (deftest literal-fn (base) 20 | (assert-true 21 | (check-it (generator (list (integer))) 22 | (lambda (xs) 23 | (every (fn (x y) 24 | (is y (+ x 2))) 25 | xs 26 | (map [+ _ 2] xs)))))) 27 | 28 | (deftest single (base) 29 | (assert-true 30 | (check-it (generator (list (integer) :length 1)) 31 | #'single)) 32 | (assert-true 33 | (check-it (generator (list (integer) :min-length 2)) 34 | (complement #'single))) 35 | (assert-false (single '()))) 36 | 37 | (deftest pair (base) 38 | (assert-true 39 | (check-it (generator (list (integer))) 40 | (lambda (xs) 41 | (is (len (clamp::pair xs)) 42 | (ceiling (len xs) 2)))) 43 | (check-it (generator (list (integer))) 44 | (lambda (xs) 45 | (iso (flat (clamp::pair xs))))))) 46 | 47 | (deftest if (base) 48 | (assert-expands (cond (a b) (c d)) (if a b c d)) 49 | (assert-expands (cond (a b) (t c)) (if a b c))) 50 | -------------------------------------------------------------------------------- /clamp-tests.asd: -------------------------------------------------------------------------------- 1 | (in-package :asdf-user) 2 | 3 | (defsystem "clamp-tests" 4 | :description "tests for clamp" 5 | :depends-on ("clunit" "check-it" "clamp" "clamp-experimental") 6 | :serial t 7 | :components ((:module "tests" 8 | :components ((:file "clamp-suite") 9 | (:file "base-suite") 10 | (:file "binding-suite") 11 | (:file "conditionals-suite") 12 | (:file "fns-suite") 13 | (:file "fnops-suite") 14 | (:file "hof-suite") 15 | (:file "iter-suite") 16 | (:file "list-suite") 17 | (:file "print-suite") 18 | (:file "memoize-suite") 19 | (:file "misc-suite") 20 | (:file "setforms-suite") 21 | (:file "tables-suite") 22 | (:file "strings-suite") 23 | (:file "sort-suite") 24 | (:file "io-suite") 25 | 26 | (:file "clamp-experimental-suite") 27 | (:file "destructuring-suite") 28 | (:file "coerce-suite") 29 | (:file "ssyntax-suite") 30 | (:file "lisp1-suite"))))) 31 | 32 | (defmethod perform ((op test-op) (c (eql (find-system :clamp-tests)))) 33 | (let ((*package* (find-package :clamp-tests))) 34 | (print (symbol-call :clamp-tests :run-suite (intern* :clamp :clamp-tests))))) 35 | -------------------------------------------------------------------------------- /src/io.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are several utilities for performing i/o. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (mac w/infile (var file &body body) 7 | "Binds VAR to the input stream created from FILE and will 8 | automatically close it when leaving the w/infile." 9 | `(w/file (,var ,file :direction :input) ,@body)) 10 | 11 | (mac w/outfile (var file &body body) 12 | "Binds VAR to the output stream created from FILE and will 13 | automatically close it when leaving w/outfile. 14 | WARNING: This will delete the old file if it already exists." 15 | `(w/file (,var ,file :direction :output :if-exists :supersede) ,@body)) 16 | 17 | (mac w/appendfile (var file &body body) 18 | "Equivalent to w/outfile but appends to FILE instead of superseding 19 | it." 20 | `(w/file (,var ,file :direction :output :if-exists :append) ,@body)) 21 | 22 | (def allchars (str) 23 | "Returns a string of every char from the input stream, STR." 24 | (tostring 25 | (whiler c (readc :from str :eof nil) nil 26 | (writec c)))) 27 | 28 | (def filechars (name) 29 | "Returns a string of every char in the file NAME." 30 | (w/infile in name (allchars in))) 31 | 32 | (def readfile (name) 33 | "Reads all of the expressions in the file NAME and returns a list 34 | of the results." 35 | (w/infile s name (drain (read :from s :eof nil)))) 36 | 37 | (def readfile1 (name) 38 | "Reads a single expression by the file NAME." 39 | (w/infile s name (read :from s))) 40 | 41 | (def writefile (val file) 42 | "Writes VAL to FILE." 43 | ;; For some reason the Arc version moves the file to a temporary 44 | ;; version first then renames it. 45 | (w/outfile s file 46 | (prin1 val s)) 47 | val) 48 | -------------------------------------------------------------------------------- /src/time.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp) 2 | (use-syntax :clamp) 3 | 4 | (defparameter seconds-per-minute* 60 "The number of seconds per minute.") 5 | (defparameter minutes-per-hour* 60 "The number of minutes per hour.") 6 | (defparameter hours-per-day* 24 "The number of hours per day.") 7 | 8 | (mac time10 (expr) 9 | "Evaluates an expression 10 times and prints information about how 10 | long it takes to execute." 11 | `(time (loop repeat 10 ,expr))) 12 | 13 | (mac jtime (expr) 14 | "Equivalent to time but always returns the keyword ':ok'." 15 | `(do1 ':ok (time ,expr))) 16 | 17 | (def since (t1) 18 | "Returns the number of seconds since universal time T1." 19 | (- (seconds) t1)) 20 | 21 | (def minutes-since (t1) 22 | "Returns the number of minutes since universal time T1." 23 | (/ (since t1) seconds-per-minute*)) 24 | 25 | (def hours-since (t1) 26 | "Returns the number of hours since universal time T1." 27 | (/ (minutes-since t1) minutes-per-hour*)) 28 | 29 | (def days-since (t1) 30 | "Returns the number of days since universal time T1." 31 | (/ (hours-since t1) hours-per-day*)) 32 | 33 | (def date (&optional (time (seconds))) 34 | "Converts the given universal time into a list containg the year, 35 | the month, and the date. The default value is the current time." 36 | (mvb (sec min hour date month year day daylight-p zone) 37 | (decode-universal-time time) 38 | (declare (ignore sec min hour day daylight-p zone)) 39 | (list year month date))) 40 | 41 | (def datestring (&optional (time (seconds))) 42 | "Converts the given universal time into a string of the form 43 | \"YYYY-MM-DD\". The default value is the current time." 44 | (tostring (apply #'prf "~4,'0D-~2,'0D-~2,'0D" (date time)))) 45 | -------------------------------------------------------------------------------- /src/binding.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are utilities for binding variables. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (mac with (&whole whole parms &body body) 7 | "Equivalent to cl:let, but does not require parens around each 8 | individual binding. This also allows for destructuring." 9 | (if (is (car body) '=) ; If this with is within an iterate. 10 | `(iter:with ,@(cdr whole)) 11 | (let* ((pparms (pair parms)) 12 | (pats (map #'car pparms)) 13 | (vals (map #'cadr pparms))) 14 | `(destructuring-bind ,pats (list ,@vals) ,@body)))) 15 | 16 | (mac let (var val &body body) 17 | "Equivalent to with, except binds only one variable." 18 | `(with (,var ,val) ,@body)) 19 | 20 | (mac ret (var val &body body) 21 | "Equivalent to clamp:let, but the result of a ret expression is the 22 | final value of VAR." 23 | `(let ,var ,val ,@body ,var)) 24 | 25 | ;; I need to figure out a better name for this since the name makes it 26 | ;; seem like withs but it behaves like with. 27 | (mac rets (parms &body body) 28 | "Same as with, but returns the values of all of the variables." 29 | `(with ,parms 30 | ,@body 31 | (values ,@(map #'car (pair parms))))) 32 | 33 | (mac rets1 (parms &body body) 34 | "Same as rets but only returns the value of the first variable." 35 | `(values (rets ,parms ,@body))) 36 | 37 | (mac flet1 (name args fbody &body body) 38 | "Equivalent to flet, but only for one procedure definition." 39 | `(flet ((,name ,args ,fbody)) ,@body)) 40 | 41 | (mac withs (parms &body body) 42 | "Equivalent to let*, but allows destructuring." 43 | (if (no parms) 44 | `(do ,@body) 45 | `(let ,(car parms) ,(cadr parms) 46 | (withs ,(cddr parms) ,@body)))) 47 | -------------------------------------------------------------------------------- /tests/fnops-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite fnops (clamp)) 5 | 6 | (deftest compose (fnops) 7 | (assert-eql 5 (call (compose #'1+ #'length) '(1 2 3 4))) 8 | (assert-equal '(5) (call (compose #'list #'1-) 6))) 9 | 10 | (deftest fif (fnops) 11 | (assert-eql 5 (call (fif) 5)) 12 | (assert-eql 6 (call (fif #'odd #'1+ #'1-) 5)) 13 | (assert-eql 5 (call (fif #'odd #'1+ #'1-) 6)) 14 | (assert-eql 0 (call (fif #'plusp #'1+ #'minusp #'1-) 0)) 15 | (assert-eql 2 (call (fif #'plusp #'1+ #'minusp #'1-) 1)) 16 | (assert-eql -2 (call (fif #'plusp #'1+ #'minusp #'1-) -1))) 17 | 18 | (deftest andf (fnops) 19 | (assert-true (call (andf #'integerp #'even) 4)) 20 | (assert-false (call (andf #'integerp #'even) 3.5)) 21 | (assert-false (call (andf #'integerp #'even) 3)) 22 | (assert-eql 5 (call (andf #'integerp #'even #'1+) 4)) 23 | (assert-true (call (andf #'> #'multiple) 10 5))) 24 | 25 | (deftest orf (fnops) 26 | (assert-true (call (orf #'even #'plusp) 4)) 27 | (assert-true (call (orf #'even #'plusp) 3)) 28 | (assert-true (call (orf #'even #'plusp) -2)) 29 | (assert-false (call (orf #'even #'plusp) -3)) 30 | (assert-false (call (orf #'> #'<) 5 5))) 31 | 32 | (deftest curry (fnops) 33 | (assert-eql 15 (call (curry #'+ 5) 10)) 34 | (assert-eql 75 (call (curry #'+ 5 10 15) 20 25)) 35 | (assert-eql 55 (call (curry #'reduce #'+) (range 1 10)))) 36 | 37 | (deftest rcurry (fnops) 38 | (assert-eql 15 (call (rcurry #'+ 5) 10)) 39 | (assert-eql 75 (call (rcurry #'+ 5 10 15) 20 25)) 40 | (assert-eql 55 (call (rcurry #'reduce (range 1 10)) #'+))) 41 | 42 | (deftest flip (fnops) 43 | (assert-equal '(1 2 3) (call (flip #'cons) '(2 3) 1)) 44 | (assert-equal '(3 2 1) (reduce (flip #'cons) '(1 2 3) 45 | :initial-value '()))) 46 | -------------------------------------------------------------------------------- /src/defalias.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Definitions for defalias which allows redefinition of 2 | ;;;; macros, procedures, and special forms. 3 | 4 | (in-package :clamp) 5 | 6 | (defun macrop (x) 7 | "Is this a macro?" 8 | (and (symbolp x) (macro-function x))) 9 | 10 | (defun make-macro (new old &optional doc) 11 | "Generates the code for making the macros NEW and OLD equivalent." 12 | (cl:let ((rest (gensym "REST"))) 13 | `(eval-when (:compile-toplevel :load-toplevel :execute) 14 | (setf (macro-function ',new) 15 | (macro-function ',old) 16 | (documentation ',new 'function) 17 | ,(or doc `(documentation ',old 'function)))))) 18 | 19 | (defun fnp (x) 20 | "Is this a procedure?" 21 | (and (symbolp x) (symbol-function x))) 22 | 23 | (defun make-fn (new old &optional doc) 24 | "Generates the code for making NEW and OLD the same procedure." 25 | `(eval-when (:compile-toplevel :load-toplevel :execute) 26 | (setf (symbol-function ',new) 27 | (symbol-function ',old) 28 | (documentation ',new 'function) 29 | ,(or doc `(documentation ',old 'function))))) 30 | 31 | (defun make-special-macro (new old) 32 | "Generates the code to create a macro NEW which expands into a use 33 | of the special form OLD." 34 | (cl:let ((rest (gensym "REST"))) 35 | `(defmacro ,new (&rest ,rest) 36 | `(,',old ,@,rest)))) 37 | 38 | (defmacro defalias (new old &optional doc) 39 | "Makes a use of NEW the equivalent to a use of OLD. Works on 40 | procedures, macros, and (most) special forms." 41 | (cond ((special-operator-p old) 42 | (make-special-macro new old)) 43 | ((macrop old) 44 | (make-macro new old doc)) 45 | ((fnp old) 46 | (make-fn new old doc)) 47 | (:else 48 | (error "Don't know what to do for object ~A of type ~A" 49 | old (type-of old))))) 50 | -------------------------------------------------------------------------------- /tests/ssyntax-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :experimental-tests) 2 | (use-syntax :clamp) 3 | 4 | (deftest notf (clamp-experimental) 5 | (w/ssyntax 6 | (assert-true (~idfn nil)) 7 | (assert-false (~idfn t)) 8 | (assert-false (~not nil)) 9 | (assert-true (~not t)) 10 | (assert-true (~is 5 4)) 11 | (assert-false (~is 5 5)) 12 | (assert-equal '(t nil t nil t) (map ~even (range 1 5))) 13 | (assert-equal '(nil t nil t nil) (map ~odd (range 1 5))) 14 | (assert-true (~or nil nil nil)) 15 | (assert-false (~or nil nil t)))) 16 | 17 | (deftest andf (clamp-experimental) 18 | (w/ssyntax 19 | (assert-false (integerp&plusp -5.5)) 20 | (assert-false (integerp&plusp 5.5)) 21 | (assert-false (integerp&plusp -5)) 22 | (assert-true (integerp&plusp 4)) 23 | (assert-equal '(nil nil nil t) (map integerp&even '(-5.5 5.5 -5 4))) 24 | (assert-true (integerp&plusp&even 6)) 25 | (assert-false (integerp&plusp&even 5.5)) 26 | (assert-false (integerp&plusp&even -4)))) 27 | 28 | (deftest compose (clamp-experimental) 29 | (w/ssyntax 30 | (assert-equal '((5 . 10)) (list+cons 5 10)) 31 | (assert-equal '(6) (list+inc 5)) 32 | (assert-equal '(((1))) (list+list+list 1)))) 33 | 34 | (deftest access (clamp-experimental) 35 | (w/ssyntax 36 | (let xs '((1 2 3) (4 5 6) (7 8 9)) 37 | (assert-equal '(1 2 3) xs.0) 38 | (assert-equal '(4 5 6) xs.1) 39 | (let x 2 40 | (assert-equal '(7 8 9) xs.x)) 41 | (assert-eql 5 xs.1.1) 42 | (assert-eql 7 xs.2.0)) 43 | (let tab (obj a (obj c 1 d 2) b (obj e 3 f 4)) 44 | (assert-equalp (obj c 1 d 2) tab!a) 45 | (assert-equalp (obj e 3 f 4) tab!b) 46 | (let x 'a 47 | (assert-equalp (obj c 1 d 2) tab.x)) 48 | (assert-eql 2 tab!a!d) 49 | (assert-eql 3 tab!b!e)) 50 | (let array #2a ((1 2) (3 4)) 51 | (assert-equalp #(1 2) array.0) 52 | (assert-equalp #(3 4) array.1) 53 | (assert-equalp 3 array.1.0)))) 54 | -------------------------------------------------------------------------------- /src/read.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are utilities that make it easier to read input. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (def readb (&key (from *standard-input*) (eof nil eof-p)) 7 | "Reads a byte from FROM. If this reaches the end of the file, 8 | it signals error if EOF was not supplied. If EOF was supplied, 9 | returns EOF." 10 | (read-byte from (no eof-p) eof)) 11 | 12 | (def readc (&key (from *standard-input*) (eof nil eof-p) (recur nil)) 13 | "Reads a char from FROM. If this reaches the end of the file signal 14 | an error if EOF was not supplied. If EOF was supplied, return EOF. 15 | The RECUR argument is if it is possible this call can lead to 16 | another call to some version of read." 17 | (read-char from (no eof-p) eof recur)) 18 | 19 | (def peekc (&key (from *standard-input*) (eof nil eof-p) 20 | (recur nil) (type nil)) 21 | "Same as readc but leaves the char on the stream. If TYPE is nil 22 | return the next char. If TYPE is t, return the next char after 23 | skipping whitespace. Otherwise if TYPE is a char, return the 24 | next char that is char= to TYPE." 25 | (peek-char type from (no eof-p) eof recur)) 26 | 27 | (def read (&key (from *standard-input*) (eof nil eof-p) (recur nil)) 28 | "Same as cl:read but uses keyword arguments." 29 | (cl:read from (no eof-p) eof recur)) 30 | 31 | (def read-line (&key (from *standard-input*) (eof nil eof-p) (recur nil)) 32 | "Same as cl:read-line but uses keyword arguments." 33 | (cl:read-line from (no eof-p) eof recur)) 34 | 35 | (def readall (&key (from *standard-input*) (eof nil) (recur nil)) 36 | "Reads every expression from FROM, which can be either a string or 37 | an input stream. Will stop when either the eof file is reached or a 38 | value equivalent to EOF is read in." 39 | (loop with in = (if (isa from 'string) (instring from) from) 40 | for exp = (read :from in :eof eof :recur recur) 41 | until (is exp eof) 42 | collect exp)) 43 | -------------------------------------------------------------------------------- /src/aliases.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are several cl operations which are aliased for clamp. 2 | 3 | (in-package :clamp) 4 | 5 | ;;;; Special Forms 6 | (defalias after unwind-protect) 7 | (defalias do progn) 8 | 9 | ;;;; Macros 10 | (defalias ++ incf) 11 | (defalias -- decf) 12 | (defalias = setf) 13 | (defalias def defun) 14 | (defalias digit digit-char-p) 15 | (defalias do1 prog1) 16 | (defalias do2 prog2) 17 | (defalias doc documentation) 18 | (defalias err error) 19 | (defalias errsafe ignore-errors) 20 | (defalias mac defmacro) 21 | (defalias mvb multiple-value-bind) 22 | (defalias mvl multiple-value-list) 23 | (defalias swap rotatef) 24 | (defalias w/file with-open-file) 25 | 26 | ;;;; Procedures. 27 | (defalias all every) 28 | (defalias alphadig alphanumericp) 29 | (defalias bound boundp) 30 | (defalias call funcall) 31 | (defalias const constantly) 32 | (defalias cut subseq) 33 | (defalias dec 1-) 34 | (defalias dedup delete-duplicates) 35 | (defalias even evenp) 36 | (defalias file-exists probe-file) 37 | (defalias idfn identity) 38 | (defalias inc 1+) 39 | (defalias inside get-output-stream-string) 40 | (defalias inst make-instance) 41 | (defalias instring make-string-input-stream) 42 | (defalias is eql) 43 | (defalias isa typep) 44 | (defalias iso equalp) 45 | (defalias join append) 46 | (defalias lastcons cl:last) 47 | (defalias len length) 48 | (defalias letter alpha-char-p) 49 | (defalias macex macroexpand) 50 | (defalias macex1 macroexpand-1) 51 | (defalias maptable maphash) 52 | (defalias negative minusp) 53 | (defalias no not) 54 | (defalias notf complement) 55 | (defalias nrev nreverse) 56 | (defalias odd oddp) 57 | (defalias outstring make-string-output-stream) 58 | (defalias positive plusp) 59 | (defalias rand random) 60 | (defalias readstring1 read-from-string) 61 | (defalias redup remove-duplicates) 62 | (defalias rev reverse) 63 | (defalias seconds get-universal-time) 64 | (defalias table make-hash-table) 65 | (defalias trunc truncate) 66 | (defalias uniq gensym) 67 | (defalias writec write-char) 68 | -------------------------------------------------------------------------------- /tests/sort-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite sort (clamp)) 5 | 6 | (deftest compare (sort) 7 | (assert-true (call (compare #'< #'len) '(1 2) '(1 2 3))) 8 | (assert-false (call (compare #'< #'len) '(1 2 3) '(1 2 3)))) 9 | 10 | (deftest best (sort) 11 | (assert-eql 5 (best #'< '(10 9 5 7 8))) 12 | (assert-eql 11 (best #'> '(10 9 5 7 11 4))) 13 | (assert-equal '(1 2) (best #'< '((1 2 3) (4 5 6) (1 2)) #'len)) 14 | (assert-equal '(1 2 3) (best #'> '((1 2 3) (4 5) (1 2)) #'len))) 15 | 16 | (deftest bestn (sort) 17 | (assert-equal '(1 2 3) (bestn 3 #'< '(6 1 3 5 9 2 6))) 18 | (assert-equal '(6 5 4) (bestn 3 #'> '(1 5 4 3 2 6))) 19 | (assert-equal '(() (1)) (bestn 2 #'< '((1 2) () (1 2 3) (1)) #'len)) 20 | (assert-equal '(1 2 3) (bestn 3 #'< #(6 1 3 5 9 2 6))) 21 | (assert-equal '(6 5 4) (bestn 3 #'> #(1 5 4 3 2 6))) 22 | (assert-equal '(() (1)) (bestn 2 #'< #((1 2) () (1 2 3) (1)) #'len))) 23 | 24 | (deftest sort (sort) 25 | (assert-equal '(1 2 3) (sort #'< '(3 1 2))) 26 | (assert-equal '(1 2 3 4 5 6) (sort #'< '(5 2 3 4 1 6))) 27 | (assert-equal '(() (1) (1 2)) (sort #'< '((1 2) () (1)) #'len)) 28 | (assert-equalp #(1 2 3) (sort #'< #(3 1 2))) 29 | (assert-equalp #(1 2 3 4 5 6) (sort #'< #(5 2 3 4 1 6))) 30 | (assert-equalp #(() (1) (1 2)) (sort #'< #((1 2) () (1)) #'len))) 31 | 32 | (deftest nsort (sort) 33 | (assert-equal '(1 2 3) (nsort #'< (list 3 1 2))) 34 | (assert-equal '(1 2 3 4 5 6) (nsort #'< (list 5 2 3 4 1 6))) 35 | (assert-equal '(() (1) (1 2)) (nsort #'< (list '(1 2) '() '(1)) #'len)) 36 | (assert-equalp #(1 2 3) (nsort #'< (vector 3 1 2))) 37 | (assert-equalp #(1 2 3 4 5 6) (nsort #'< (vector 5 2 3 4 1 6))) 38 | (assert-equalp #(() (1) (1 2)) (nsort #'< (vector '(1 2) '() '(1)) #'len))) 39 | 40 | (deftest med (sort) 41 | (assert-eql 2 (med #'< '(1 3 2))) 42 | (assert-eql 2 (med #'< '(4 3 1 2))) 43 | (assert-eql 3 (med #'< '(3 5 4 1 2))) 44 | (assert-eql 3 (med #'< '(5 3 6 2 1 4))) 45 | (assert-equalp "def" (med #'string< '("def" "ghi" "abc"))) 46 | (assert-equal '(1) (med #'< '((1 2 3) () (1) (1 2)) #'len))) 47 | -------------------------------------------------------------------------------- /src/sort.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Utilities for specific kinds of sorting. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (def compare (comparer scorer) 7 | "Returns a procedure which compares its arguments score from SCORER 8 | using COMPARER. Generally should use the :key argument to other 9 | procedures instead of using compare." 10 | (fn (x y) (call comparer (funcall scorer x) (funcall scorer y)))) 11 | 12 | ;;; It should be easy to modify best so that it works on all 13 | ;;; sequences as well as lists. 14 | (def best (f xs &optional (key #'identity)) 15 | "Finds the first element of the list XS if it was sorted using 16 | the procedure F." 17 | (if (no xs) 18 | nil 19 | (ret wins (car xs) 20 | (let score (call key wins) 21 | (each elt (cdr xs) 22 | (let elt-score (call key elt) 23 | (when (call f elt-score score) 24 | (= wins elt 25 | score elt-score)))))))) 26 | 27 | (def bestn (n f seq &optional (key #'identity)) 28 | "Returns a list containg the first N elements of SEQ if it was 29 | sorted using the procedure F." 30 | (firstn n (sort f seq key))) 31 | 32 | (def nsort (comparer sequence &optional (key #'idfn)) 33 | "Destructively sorts SEQUENCE using COMPARER." 34 | (cl:sort sequence comparer :key key)) 35 | 36 | (def sort (comparer sequence &optional (key #'idfn)) 37 | "Non-destructively sorts SEQUENCE using COMPARER." 38 | (nsort comparer (copy-seq sequence) key)) 39 | 40 | (def nssort (comparer sequence &optional (key #'idfn)) 41 | "Destructively and stabily sort SEQUENCE using COMPARER." 42 | (cl:stable-sort sequence comparer :key key)) 43 | 44 | (def ssort (comparer sequence &optional (key #'idfn)) 45 | "Non-destructively and stabily sort SEQUENCE using COMPARER." 46 | (nssort comparer sequence key)) 47 | 48 | (def med (fn seq &optional key) 49 | "Returns the median of a sequence. The median is the middle element 50 | when the list is sorted using FN. If the list contains an even 51 | number of elements, the middle element that comes first is 52 | returned." 53 | (elt (sort fn seq key) (dec (ceiling (len seq) 2)))) 54 | -------------------------------------------------------------------------------- /src/setforms.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp) 2 | (use-syntax :clamp) 3 | 4 | 5 | (def setforms (exp &optional env) 6 | "Given an expression for a place, returns three values. The first 7 | one is a list of variables and values that should be bound with 8 | 'withs' to create an environment for the other expressions to be 9 | evaluated in. The second value is an expression which will get the 10 | value of the place. The last value is a procedure name (which will 11 | generally be a lambda expression), that when called with the new 12 | value will set the place to that value." 13 | (mvb (vars forms var set access) (get-setf-expansion exp env) 14 | (values (mappend #'list vars forms) 15 | access 16 | `(lambda ,var ,set)))) 17 | 18 | (mac zap (op place &rest args &environment env) 19 | "Assigns the result of calling OP on the rest of the arguments 20 | (including PLACE) to PLACE. For example (zap #'+ x n) is 21 | equivalent to (incf x n)." 22 | (mvb (vars access set) (setforms place env) 23 | `(withs ,vars 24 | (,set (call ,op ,access ,@args))))) 25 | 26 | (mac or= (place new &environment env) 27 | "If PLACE is nil, assign the result of evaluating NEW there. 28 | Otherwise returns whatever value was already in PLACE and does not 29 | evaluate NEW." 30 | (mvb (vars access set) (setforms place env) 31 | `(withs ,vars 32 | (,set (or ,access ,new))))) 33 | 34 | (mac or2= (place new &environment env) 35 | "Equivalent to or= but will not carry through with the assignment 36 | if accessing PLACE has a second return value which is non-nil." 37 | (mvb (vars access set) (setforms place env) 38 | (w/uniq (val win) 39 | `(withs ,vars 40 | (mvb (,val ,win) ,access 41 | (,set (if (or ,val ,win) ,val ,new))))))) 42 | 43 | (mac set (&rest args) 44 | "Sets every one of its arguments to t." 45 | `(do ,@(map (fn (a) `(= ,a t)) args))) 46 | 47 | (mac wipe (&rest args) 48 | "Sets every one of its arguments to nil." 49 | `(do ,@(map (fn (a) `(= ,a nil)) args))) 50 | 51 | (mac pull (test place) 52 | "Removes all of the elements in PLACE that satisfy test and stores 53 | that value back into PLACE." 54 | (w/uniq g 55 | (mvb (binds val setter) (setforms place) 56 | `(withs ,(join (list g test) binds) 57 | (,setter (rem ,g ,val)))))) 58 | -------------------------------------------------------------------------------- /tests/strings-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite strings (clamp)) 5 | 6 | (deftest newstring (strings) 7 | (assert-eql 5 (len (newstring 5))) 8 | (assert-eql 10 (len (newstring 10))) 9 | (assert-eql 10 (len (newstring 10 #\a))) 10 | (assert-equalp "aaaa" (newstring 4 #\a))) 11 | 12 | (deftest whitec (strings) 13 | (assert-true (whitec #\space)) 14 | (assert-true (whitec #\newline)) 15 | (assert-true (whitec #\tab)) 16 | (assert-true (whitec #\return)) 17 | (assert-false (whitec #\a)) 18 | (assert-false (whitec #\&))) 19 | 20 | (deftest nonwhite (strings) 21 | (assert-false (nonwhite #\space)) 22 | (assert-false (nonwhite #\newline)) 23 | (assert-false (nonwhite #\tab)) 24 | (assert-false (nonwhite #\return)) 25 | (assert-true (nonwhite #\a)) 26 | (assert-true (nonwhite #\&))) 27 | 28 | (deftest punc (strings) 29 | (assert-true (punc #\.)) 30 | (assert-true (punc #\,)) 31 | (assert-true (punc #\;)) 32 | (assert-true (punc #\:)) 33 | (assert-true (punc #\!)) 34 | (assert-true (punc #\?)) 35 | (assert-false (punc #\a)) 36 | (assert-false (punc #\&))) 37 | 38 | (deftest tokens (strings) 39 | (assert-equalp '("abc" "def" "ghi") (tokens "abc def ghi")) 40 | (assert-equalp '("abc" "def" "ghi") 41 | (tokens (tostring (prf "abc~%def~%ghi~%")) 42 | #\newline))) 43 | 44 | (deftest upcase (strings) 45 | (assert-eql #\A (upcase #\a)) 46 | (assert-eql #\A (upcase #\A)) 47 | (assert-eql #\0 (upcase #\0)) 48 | (assert-equal "HELLO" (upcase "HeLLo")) 49 | (assert-eql 'hello (upcase '|hello|))) 50 | 51 | (deftest downcase (strings) 52 | (assert-eql #\a (downcase #\A)) 53 | (assert-eql #\a (downcase #\a)) 54 | (assert-eql #\0 (downcase #\0)) 55 | (assert-equal "hello" (downcase "HeLLo")) 56 | (assert-eql '|hello| (downcase 'hello))) 57 | 58 | (deftest headmatch (strings) 59 | (assert-true (headmatch "abc" "abcde")) 60 | (assert-false (headmatch "abc" "bcde")) 61 | (assert-true (headmatch "abc" "0abcde" 1)) 62 | (assert-false (headmatch "abc" "abcde" 1))) 63 | 64 | (deftest begins (strings) 65 | (assert-true (begins "abcde" "abc")) 66 | (assert-false (begins "bcde" "abc")) 67 | (assert-true (begins "0abcde" "abc" 1)) 68 | (assert-false (begins "abcde" "abc" 1))) 69 | 70 | (deftest ellipsize (strings) 71 | (assert-equalp "hello..." (ellipsize "hello world" 5)) 72 | (assert-equalp "hello" (ellipsize "hello" 5))) 73 | -------------------------------------------------------------------------------- /clamp.asd: -------------------------------------------------------------------------------- 1 | (in-package :asdf-user) 2 | 3 | (defsystem "clamp" 4 | :description "Common Lisp with Arc Macros and Procedures" 5 | :version "0.3" 6 | :author "malisper" 7 | :depends-on ("iterate" "cl-syntax") 8 | :in-order-to ((test-op (test-op :clamp-tests))) 9 | :components ((:module "src" 10 | :components ((:file "package") 11 | (:file "defalias" :depends-on ("package")) 12 | (:file "aliases" :depends-on ("defalias")) 13 | (:file "syntax" :depends-on ("package")) 14 | (:file "base" :depends-on ("aliases" "syntax")) 15 | (:file "read" :depends-on ("aliases")) 16 | (:file "hof" :depends-on ("aliases" "base")) 17 | (:file "binding" :depends-on ("hof")) 18 | (:file "fns" :depends-on ("aliases" "base" "binding")) 19 | (:file "print" :depends-on ("aliases" "base" "binding" "hof")) 20 | (:file "time" :depends-on ("aliases" "print")) 21 | (:file "macros" :depends-on ("binding" "print")) 22 | (:file "fnops" :depends-on ("binding" "base" "conditionals")) 23 | (:file "setforms" :depends-on ("binding" "macros")) 24 | (:file "memoize" :depends-on ("setforms")) 25 | (:file "strings" :depends-on ("misc")) 26 | (:file "iter" :depends-on ("hof" "macros" "fnops")) 27 | (:file "list" :depends-on ("aliases" "macros" "fns" "base")) 28 | (:file "conditionals" :depends-on ("macros" "list" "fns")) 29 | (:file "misc" :depends-on ("macros" "conditionals" "iter" "list" "hof" "fnops")) 30 | (:file "sort" :depends-on ("binding" "list" "iter")) 31 | (:file "io" :depends-on ("iter" "read")) 32 | (:file "tables" :depends-on ("binding" "iter")) 33 | (:file "disk" :depends-on ("macros" "conditionals" "io")) 34 | (:file "code" :depends-on ("iter" "hof" "misc" "read" "io")) 35 | (:file "deftem" :depends-on ("binding" "list" "hof" "macros" "print")))))) 36 | -------------------------------------------------------------------------------- /experimental/ssyntax-defs.lisp: -------------------------------------------------------------------------------- 1 | ;;;; The definitions for different ssyntax. 2 | 3 | (in-package :experimental) 4 | (use-syntax :clamp) 5 | 6 | (defssyntax-test notf (sym name) 7 | (declare (ignore sym)) 8 | (and (len> name 1) 9 | (char= #\~ (char name 0)))) 10 | 11 | (defssyntax-sym-mac notf (sym name) 12 | `(,sym (notf #',(intern (cut name 1))))) 13 | 14 | (defssyntax-macro notf (sym name) 15 | `(,sym (&body body) 16 | `(not (,',(intern (cut name 1)) ,@body)))) 17 | 18 | (defssyntax-test compose (sym name) 19 | (declare (ignore sym)) 20 | (and (pos #\+ name) 21 | (len> name 2))) ; This removes + and 1+ from being detected. 22 | 23 | (defssyntax-sym-mac compose (sym name) 24 | (ado (tokens name #\+) 25 | (map #'intern it) 26 | (map (fn (f) `#',f) it) 27 | `(,sym (compose ,@it)))) 28 | 29 | (defssyntax-macro compose (sym name) 30 | (ado (tokens name #\+) 31 | (map #'intern it) 32 | `(,sym (&body body) 33 | ;; (f+g+h ...) will expand into (f (g (h ...))) therefore 34 | ;; we need to work from the back and create a new list 35 | ;; containing the fn and the previous expression. 36 | (reduce #'list ',(butlast it) 37 | :from-end t 38 | :initial-value `(,',(last it) ,@body))))) 39 | 40 | (defssyntax-test andf (sym name) 41 | (declare (ignore sym)) 42 | (find #\& name)) 43 | 44 | (defssyntax-sym-mac andf (sym name) 45 | (ado (tokens name #\&) 46 | (map #'intern it) 47 | (map (fn (f) `#',f) it) 48 | `(,sym (andf ,@it)))) 49 | 50 | (defssyntax-macro andf (sym name) 51 | (declare (ignore name)) 52 | `(,sym (&body body) 53 | `(call ,',sym ,@body))) 54 | 55 | (defun get-ssyntax (c) 56 | "Is this ssyntax for get?" 57 | (in c #\. #\!)) 58 | 59 | (defssyntax-test get (sym name) 60 | (declare (ignore sym)) 61 | (find #'get-ssyntax name)) 62 | 63 | (defssyntax-sym-mac get (sym name) 64 | (withs (ssyntaxes (keep #'get-ssyntax name) 65 | (obj . accessors) (map #'read-from-string 66 | (tokens name #'get-ssyntax)) 67 | calls (map (fn (ss accessor) 68 | (if (is ss #\.) accessor `',accessor)) 69 | ssyntaxes 70 | accessors)) 71 | `(,sym ,(reduce (fn (exp accessor) 72 | `(get ,exp ,accessor)) 73 | calls 74 | :initial-value obj)))) 75 | -------------------------------------------------------------------------------- /tests/print-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite print (clamp)) 5 | 6 | (deftest pr (print) 7 | (assert-equal "hello world 5" 8 | (tostring (pr "hello" " world " (+ 2 3)))) 9 | ;; This use of tostring is just so the output is not visible. 10 | (tostring (assert-eql 3 (pr (+ 1 2) (+ 4 5))))) 11 | 12 | (deftest prn (print) 13 | (assert-equal (format nil "~%") 14 | (tostring (prn))) 15 | (assert-equal (format nil "Hello World 5~%") 16 | (tostring (prn "Hello" " World " (+ 3 2)))) 17 | ;; This use of tostring is just so the output is not visible. 18 | (tostring (assert-eql 5 (prn (+ 1 4) (+ 3 7))))) 19 | 20 | (deftest prf (print) 21 | (assert-equalp "hello world five" (tostring (prf "hello world ~R" 5))) 22 | (assert-equalp "1, 2, 3" (tostring (prf "~A, ~A, ~A" 1 2 3)))) 23 | 24 | (deftest prs (print) 25 | (assert-equalp "1 2 3 4 5" (tostring (prs 1 2 3 4 5))) 26 | (assert-equalp "hello 5" (tostring (prs "hello" (+ 2 3))))) 27 | 28 | (deftest w/outstring (print) 29 | (assert-equal "Hello World 3" (w/outstring stream 30 | (princ "Hello " stream) 31 | (princ "World " stream) 32 | (princ (+ 1 2) stream))) 33 | (assert-equal "" (w/outstring stream))) 34 | 35 | (deftest tostring (print) 36 | (assert-equal "Hello World 3" (tostring (pr "Hello " "World " (+ 1 2)))) 37 | (assert-equal "" (tostring)) 38 | (assert-equal (format nil "~%") (tostring (prn)))) 39 | 40 | (deftest w/instring (print) 41 | (assert-eq 'hello (w/instring stream "Hello World" (read :from stream))) 42 | (assert-equal "Hello World" (w/instring stream "Hello World" (read-line :from stream))) 43 | (assert-equal 123 (w/instring stream "123" (parse-integer (read-line :from stream))))) 44 | 45 | (deftest fromstring (print) 46 | (assert-eq 'hello (fromstring "Hello World" (read))) 47 | (assert-equal "Hello World" (fromstring "Hello World" (read-line))) 48 | (assert-eql 123 (fromstring "123" (parse-integer (read-line))))) 49 | 50 | (deftest sp (print) 51 | (assert-equalp " " (tostring (sp))) 52 | (assert-equalp " " (tostring (sp 3)))) 53 | 54 | (deftest w/bars (print) 55 | (assert-equalp "a | b | c" (tostring (w/bars (pr "a") (pr "b") (pr "c")))) 56 | (assert-equalp "b | c" (tostring (w/bars (pr) (pr "b") (pr "c")))) 57 | (assert-equalp "a|b|c" (let bar* "|" 58 | (tostring 59 | (w/bars (pr "a") (pr "b") (pr "c")))))) 60 | -------------------------------------------------------------------------------- /src/tables.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are utilities for working with (hash) tables. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (def keys (tab) 7 | "Returns all of the keys of the table TAB." 8 | (ret result '() 9 | (maphash (fn (k v) 10 | (declare (ignore v)) 11 | (push k result)) 12 | tab))) 13 | 14 | (def vals (tab) 15 | "Returns all of the values stored in table TAB." 16 | (ret result '() 17 | (maphash (fn (k v) 18 | (declare (ignore k)) 19 | (push v result)) 20 | tab))) 21 | 22 | (def listtab (xs &rest args) 23 | "Returns a table which is equivalent to the alist XS. Takes 24 | additional arguments which are passed to table, specifying the 25 | kind of table to be created." 26 | (ret result (apply #'table args) 27 | (each (k v) xs 28 | (= (gethash k result) v)))) 29 | 30 | (def tablist (tab) 31 | "Returns an alist which is equivalent to the table TAB." 32 | (ret result '() 33 | (maphash (fn (k v) (push (list k v) result)) tab))) 34 | 35 | (mac obj (&rest args) 36 | "Creates a table with every two arguments being key/value pairs. 37 | The keys are not evaluated." 38 | `(listtab (list ,@(map [let (k v) _ `(list ',k ,v)] 39 | (pair args))) 40 | :test #'iso)) 41 | 42 | (def alref (al key &optional (cdr nil)) 43 | "Returns the value of KEY in the alist AL. If CDR is t, the value 44 | is stored in the cdr. Otherwise it is assumed it is stored in the 45 | cadr." 46 | (let pair (assoc key al) 47 | (values (if cdr (cdr pair) (cadr pair)) pair))) 48 | 49 | (def counts (seq &key (test #'iso) (key #'idfn)) 50 | "Returns a table containing how many times every element in SEQ 51 | appears. The procedure TEST needs to be able to be passed to table 52 | for creating a table." 53 | (ret result (table :test test) 54 | (each x seq 55 | (let val (call key x) 56 | (or2= (gethash val result) 0) 57 | (++ (gethash val result)))))) 58 | 59 | (def commonest (seq &key (test #'iso) (key #'idfn)) 60 | "Returns the most common element in SEQ and how often it occurs." 61 | (with (winner nil n 0) 62 | (maphash 63 | (fn (k v) 64 | (when (> v n) 65 | (= winner k 66 | n v))) 67 | (counts seq :test test :key key)) 68 | (values winner n))) 69 | 70 | (def memtable (keys &key (val t) (test #'is)) 71 | "Creates a table with all of the keys in KEYS having the value VAL." 72 | (ret result (table :test test) 73 | (each k keys 74 | (= (gethash k result) val)))) 75 | -------------------------------------------------------------------------------- /src/iter.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are macros which allow for different kinds of iteration. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (mac repeat (n &body body) 7 | "Excutes BODY N times." 8 | (if (no body) ; If this is part of iterate. 9 | `(iter:repeat ,n) 10 | `(loop repeat ,n do (do ,@body)))) 11 | 12 | (mac up (var a b &body body) 13 | "Evaluates BODY iterating from A up to B exclusive." 14 | `(loop for ,var from ,a below ,b do (do ,@body))) 15 | 16 | (mac upto (var a b &body body) 17 | "Evaluates BODY iterating from A up to B inclusive." 18 | `(loop for ,var from ,a upto ,b do (do ,@body))) 19 | 20 | ;; The name downfrom is a better name then downto because it includes 21 | ;; the higher number (the from) as opposed to down which does not. 22 | (mac downfrom (var a b &body body) 23 | "Evaluates BODY iterating from A down to B inclusive." 24 | `(loop for ,var downfrom ,a to ,b do (do ,@body))) 25 | 26 | (mac down (var a b &body body) 27 | "Evaluates BODY iterating from A (exclusive) to B (inclusive)." 28 | `(downfrom ,var (- ,a 1) ,b ,@body)) 29 | 30 | (mac while (test &body body) 31 | "Repeatedly evaluates BODY while TEST returns true." 32 | (if (no body) 33 | `(iter:while ,test) 34 | `(loop while ,test do (do ,@body)))) 35 | 36 | (mac until (test &body body) 37 | "Repeatedly evaluates BODY until TEST returns true." 38 | (if (no body) 39 | `(iter:until ,test) 40 | `(loop until ,test do (do ,@body)))) 41 | 42 | (mac each (var seq &body body) 43 | "Evaluates BODY while iterating across SEQ binding each element to 44 | VAR." 45 | `(loop for ,var in (coerce ,seq 'list) do (do ,@body))) 46 | 47 | (mac on (var seq &body body) 48 | "Equivalent to each but binds the symbol 'index' to the position of 49 | the current element in SEQ." 50 | `(loop for ,var in (coerce ,seq 'list) 51 | for index from 0 52 | do (do ,@body))) 53 | 54 | (mac whilet (var test &body body) 55 | "Executes BODY until TEST returns nil. The value of TEST is bound 56 | to VAR on each iteration." 57 | `(loop for ,var = ,test 58 | while ,var 59 | do (do ,@body))) 60 | 61 | (mac whiler (var expr endval &body body) 62 | "Executes BODY until the result of expr passes the testified 63 | version of ENDVAL. The value of EXPR is bound to VAR on each 64 | iteration." 65 | (w/uniq gtest 66 | `(loop with ,gtest = (testify ,endval) 67 | for ,var = ,expr 68 | until (call ,gtest ,var) 69 | do (do ,@body)))) 70 | 71 | (mac forlen (var seq &body body) 72 | "Executes BODY, iterating from 0 to (len seq) (exclusive)." 73 | `(up ,var 0 (len ,seq) 74 | ,@body)) 75 | -------------------------------------------------------------------------------- /src/strings.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are utilities for working with strings. 2 | 3 | ;;;; For most string related operations I suggest using some regex 4 | ;;;; based library. Using such a library removes the purpose of most 5 | ;;;; of the Arc utilities for string searching. 6 | 7 | (in-package :clamp) 8 | (use-syntax :clamp) 9 | 10 | (defalias string mkstr) 11 | (deftype string () 'cl:string) 12 | 13 | (def newstring (length &optional char) 14 | "Creates a newstring of length LENGTH of the character CHAR." 15 | ;; The value nil can't be passed as the initial-element. 16 | (if char 17 | (make-string length :initial-element char) 18 | (make-string length))) 19 | 20 | (def whitec (c) 21 | "Is this character whitespace (a space, newline, tab, or return)?" 22 | (in c #\space #\newline #\tab #\return)) 23 | 24 | (def nonwhite (c) 25 | "Is this character not a whitespace character?" 26 | (no (whitec c))) 27 | 28 | (def punc (c) 29 | "Is this character punctuation?" 30 | (in c #\. #\, #\; #\: #\! #\?)) 31 | 32 | (def tokens (str &optional (sep #'whitec)) 33 | "Returns a list of containg all of the parts of str separated by 34 | using sep (a test)." 35 | (let test (testify sep) 36 | (loop for prev = 0 then (+ next 1) 37 | for next = (pos test str :start prev) 38 | for substr = (cut str prev next) 39 | ;; There must be a better way to test for the empty string. 40 | unless (is 0 (len substr)) 41 | collect substr 42 | while next))) 43 | 44 | (def upcase (x) 45 | "Converts a string or a char to uppercase." 46 | (typecase x 47 | string (string-upcase x) 48 | character (char-upcase x) 49 | symbol (intern (upcase (symbol-name x))))) 50 | 51 | (def downcase (x) 52 | "Converts a string or a char to lowercase." 53 | (typecase x 54 | string (string-downcase x) 55 | character (char-downcase x) 56 | symbol (intern (downcase (symbol-name x))))) 57 | 58 | (def headmatch (pat seq &optional (start 0)) 59 | "Does SEQ, starting from START, match PAT?" 60 | (loop for i from 0 below (len pat) 61 | for j from start 62 | always (is (elt pat i) (elt seq j)))) 63 | 64 | (def begins (seq pat &optional (start 0)) 65 | "Equivalent to headmatch, but SEQ and PAT are reversed. Also this 66 | tests whether SEQ is long enough first." 67 | (unless (> (len pat) (- (len seq) start)) 68 | (headmatch pat seq start))) 69 | 70 | (def ellipsize (str &optional (limit 80)) 71 | "If the length of STR is greater than LIMIT, take the first LIMIT 72 | characters and append '...' to them." 73 | (if (<= (len str) limit) 74 | str 75 | (mkstr (cut str 0 limit) "..."))) 76 | -------------------------------------------------------------------------------- /src/print.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Utilities for printing. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (def pr (&rest args) 7 | "Prints all of its arguments to *standard-output* in a human 8 | readable format." 9 | (map #'princ args) 10 | (car args)) 11 | 12 | (def prn (&rest args) 13 | "Prints all of its arguments to *standard-output* in a human 14 | readable format with an additional newline." 15 | (do1 (apply #'pr args) 16 | (terpri))) 17 | 18 | (def prf (control-string &rest args) 19 | "Equivalent to format but automatically prints to *standard-output*." 20 | (apply #'format t control-string args)) 21 | 22 | (def prs (&rest args) 23 | "Prints the arguments seperated by spaces and returns the arguments 24 | as a list." 25 | (prf "~{~A~^ ~}" args) 26 | args) 27 | 28 | (def prns (&rest args) 29 | "The same as prs, but prints a newline at the end." 30 | (do1 (apply #'prs args) 31 | (terpri))) 32 | 33 | (mac w/outstring (var &rest body) 34 | "Creates a string output stream and binds it to VAR." 35 | `(with-output-to-string (,var) 36 | ,@body)) 37 | 38 | (mac tostring (&body body) 39 | "Collects all of the output to *standard-output* into a string." 40 | `(w/outstring *standard-output* ,@body)) 41 | 42 | (mac w/instring (var string &rest body) 43 | "Binds an string input stream which reads from STRING, to VAR." 44 | `(with-input-from-string (,var ,string) 45 | ,@body)) 46 | 47 | (mac fromstring (string &body body) 48 | "Makes the input from *standard-input* read from STRING." 49 | `(w/instring *standard-input* ,string ,@body)) 50 | 51 | (mac tofile (name &body body) 52 | "Redirects *standard-output* to the file NAME. 53 | WARNING: supersedes the file." 54 | `(w/outfile *standard-output* ,name 55 | ,@body)) 56 | 57 | (mac fromfile (name &body body) 58 | "Makes the input from *standard-input* read from the file NAME." 59 | `(w/infile *standard-input* ,name 60 | ,@body)) 61 | 62 | (def sp (&optional (n 1)) 63 | "Prints the given number of spaces." 64 | (loop repeat n 65 | do (pr " "))) 66 | 67 | (defparameter bar* " | " "The character used for w/bars.") 68 | 69 | (mac w/bars (&rest exps) 70 | "Executes each expression in EXPS and outputs the combined output 71 | of each one with bar* in between each expression." 72 | ;; The macro w/uniq is not defined until the macros file which is 73 | ;; loaded after print. 74 | (with (out (gensym) needbars (gensym)) 75 | `(let ,needbars nil 76 | (do ,@(mapeach e exps 77 | `(let ,out (tostring ,e) 78 | (unless (iso ,out "") 79 | (if ,needbars 80 | (pr bar* ,out) 81 | (do (= ,needbars t) 82 | (pr ,out)))))))))) 83 | -------------------------------------------------------------------------------- /src/deftem.lisp: -------------------------------------------------------------------------------- 1 | ;;;; This defines deftem, a macro that makes defining a class similar 2 | ;;;; to defining a structure. If no initial value is given, slots 3 | ;;;; default to nil. 4 | 5 | (in-package :clamp) 6 | (use-syntax :clamp) 7 | 8 | (defclass template () () 9 | (:documentation "The template base class.")) 10 | 11 | (defgeneric get-slots (obj) 12 | (:documentation "Returns all of the slots of the template OBJ.") 13 | (:method-combination append :most-specific-last)) 14 | 15 | (defmethod print-object ((tem template) stream) 16 | "Print the template by printing all of the slots and their values." 17 | (pprint-logical-block (stream (mappend #'idfn (redup (get-slots tem) :key #'car))) 18 | (print-unreadable-object (tem stream :type t) 19 | (pprint-indent :current 0 stream) 20 | (pprint-exit-if-list-exhausted) 21 | (format stream ":~A ~S" (pprint-pop) (pprint-pop)) 22 | (loop (pprint-exit-if-list-exhausted) 23 | (format stream " ~_:~A ~S" (pprint-pop) (pprint-pop))))) 24 | tem) 25 | 26 | (mac deftem (name-and-options &rest slots) 27 | "Define a class with a syntax similar to that of defstruct." 28 | (withs (slot-names (map #'carif slots) 29 | name (carif name-and-options) 30 | options (if (listp name-and-options) (cdr name-and-options) '()) 31 | constructor-name (or2 (alref options :constructor) (symb 'make- name)) 32 | predicate-name (or2 (alref options :predicate) (symb name '-p)) 33 | conc-name (or2 (alref options :conc-name) (symb name '-)) 34 | printer-name (alref options :print-object) 35 | direct-superclasses (alref options :include t)) 36 | `(do (defclass ,name (,@direct-superclasses template) 37 | ,(mapeach s slots 38 | (let (slot-name &optional initform) (mklist s) 39 | `(,slot-name :accessor ,(if conc-name (symb conc-name slot-name) slot-name) 40 | :initarg ,(intern (mkstr slot-name) :keyword) 41 | :initform ,initform)))) 42 | 43 | ,(when predicate-name 44 | `(def ,predicate-name (object) 45 | ,(tostring (prf "Is OBJECT of type ~(~A~)?" name)) 46 | (typep object ',name))) 47 | 48 | ,(when constructor-name 49 | (w/uniq args 50 | `(def ,constructor-name (&rest ,args &key ,@slot-names &allow-other-keys) 51 | ,(tostring (prf "Create an object of type ~(~A~)." name)) 52 | (declare (ignore ,@slot-names)) 53 | (apply #'make-instance ',name ,args)))) 54 | 55 | (defmethod get-slots append ((obj ,name)) 56 | ,(tostring (prf "Returns a flat list of the slots that belong to a ~(~A~) and their values." name)) 57 | (with-slots ,slot-names obj 58 | (list ,@(mapeach n slot-names ``(,',n ,,n))))) 59 | 60 | ,(when printer-name 61 | `(defmethod print-object ((obj ,name) stream) 62 | ,(tostring (prf "Print an object of type ~(~A~)." name)) 63 | (call #',printer-name obj stream))) 64 | 65 | ',name))) 66 | -------------------------------------------------------------------------------- /src/fnops.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are utilities for working with procedures. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (def compose (&rest fns) 7 | "Composes procedures. For example 8 | 9 | (compose #'1+ #'length) 10 | 11 | will return a procedure which returns one plus the length of a 12 | list." 13 | (if fns 14 | (with (fn1 (last fns) 15 | fns (butlast fns)) 16 | (fn (&rest args) 17 | (reduce #'call fns 18 | :from-end t 19 | :initial-value (apply fn1 args)))) 20 | #'identity)) 21 | 22 | (def fif (&rest funs) 23 | "Takes in procedures, every two of which belong to a pair where the 24 | first is a predicate, and the second is the consequent procedure 25 | (if there are an odd number of procedures, the last one can be 26 | thought of as an 'else' procedure). This returns a procedure which 27 | will apply every test in sequence and if a test returns non-nil, 28 | apply the corresponding consequent procedure. If none of the 29 | predicates return non-nil, the procedure is equivalent to the 30 | identity procedure. As an example 31 | 32 | (fif #'odd #'1+ #'1-) 33 | 34 | will return a procedure which will increment odd numbers and 35 | decrement all other numbers." 36 | (case (len funs) 37 | 0 #'idfn 38 | 1 (car funs) 39 | t (withs ((test fun . rest) funs 40 | restfun (apply #'fif rest)) 41 | (fn (&rest args) (if (apply test args) 42 | (apply fun args) 43 | (apply restfun args)))))) 44 | 45 | (def andf (f &rest fns) 46 | "Returns a procedure which lazily applies each function in sequence 47 | and returns whatever the last procedure would return if all of the 48 | other procedures return non-nil. For example 49 | 50 | (andf #'integerp #'even #'1+) 51 | 52 | will return a procedure which increments even integers, and 53 | returns nil for anything else." 54 | (if (null fns) 55 | f 56 | (let chain (apply #'andf fns) 57 | (fn (&rest args) 58 | (and (apply f args) (apply chain args)))))) 59 | 60 | (def orf (f &rest fns) 61 | "Returns a procedure which lazily applies each function in sequence 62 | and returns the result of the first procedure that returns a 63 | non-nil value. For example 64 | 65 | (orf #'odd #'zero) 66 | 67 | will return a procedure which tests for an odd number or zero." 68 | (if (null fns) 69 | f 70 | (let chain (apply #'orf fns) 71 | (fn (&rest args) 72 | (or (apply f args) (apply chain args)))))) 73 | 74 | (def curry (f &rest args1) 75 | "Curries F from the left with the other arguments. For example 76 | 77 | (curry #'reduce #'+) 78 | 79 | returns a procedure which will sum a sequence." 80 | (fn (&rest args2) (apply f (append args1 args2)))) 81 | 82 | (def rcurry (f &rest args1) 83 | "Curries F from the right with the other arguments. For example 84 | 85 | (rcurry #'map (range 1 100)) 86 | 87 | returns a procedure which will call its argument on all of the 88 | numbers from 1 to 100 and collect the results." 89 | (fn (&rest args2) (apply f (append args2 args1)))) 90 | 91 | (def flip (f) 92 | "Returns a new procedure which is the same as F but has its 93 | arguments in the reverse order." 94 | (fn (&rest args) (apply f (rev args)))) 95 | -------------------------------------------------------------------------------- /src/macros.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Utilities for writing macros. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (mac w/uniq (names &body body) 7 | "Binds every symbol in NAMES to a uniq symbol. Then executes BODY." 8 | (if (consp names) 9 | `(with ,(mappend (fn (n) `(,n (uniq (symbol-name ',n)))) 10 | names) 11 | ,@body) 12 | `(let ,names (uniq (symbol-name ',names)) ,@body))) 13 | 14 | (def mkstr (&rest args) 15 | "Returns the string representing all of the arguments." 16 | (tostring 17 | (apply #'pr args))) 18 | 19 | (def symb (&rest args) 20 | "Returns a symbol representing all of the arguments." 21 | (values (intern (apply #'mkstr args)))) 22 | 23 | ;; Based on arg-count in PAIP. 24 | (def check-len (name form xs min &key (max nil) 25 | (str "Wrong number of arguments for ~A in ~A: ~ 26 | ~A supplied, ~A~@[ to ~A~] expected.")) 27 | "Asserts that some list, XS, has between MIN and MAX elements. If 28 | XS does not have the right number of arguments STR is the error 29 | string with NAME, FORM, (len XS), MIN, MAX as its arguments." 30 | (let len-xs (len xs) 31 | (assert (and (<= min len-xs (or max min))) 32 | () str name form len-xs min max))) 33 | 34 | ;; The macro once-only is from Practical Common Lisp. The license is 35 | ;; included because it is required for the license. 36 | 37 | ;; Copyright (c) 2005, Peter Seibel All rights reserved. 38 | 39 | ;; Redistribution and use in source and binary forms, with or without 40 | ;; modification, are permitted provided that the following conditions are 41 | ;; met: 42 | 43 | ;; * Redistributions of source code must retain the above copyright 44 | ;; notice, this list of conditions and the following disclaimer. 45 | 46 | ;; * Redistributions in binary form must reproduce the above 47 | ;; copyright notice, this list of conditions and the following 48 | ;; disclaimer in the documentation and/or other materials provided 49 | ;; with the distribution. 50 | 51 | ;; * Neither the name of the Peter Seibel nor the names of its 52 | ;; contributors may be used to endorse or promote products derived 53 | ;; from this software without specific prior written permission. 54 | 55 | ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 56 | ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 57 | ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 58 | ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 59 | ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 60 | ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 61 | ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 62 | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 63 | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 64 | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 65 | ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 66 | 67 | (defmacro once-only ((&rest names) &body body) 68 | (cl:let ((gensyms (loop for n in names collect (gensym (string n))))) 69 | `(cl:let (,@(loop for g in gensyms collect `(,g (gensym)))) 70 | `(cl:let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) 71 | ,(cl:let (,@(loop for n in names for g in gensyms collect `(,n ,g))) 72 | ,@body))))) 73 | -------------------------------------------------------------------------------- /tests/misc-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite misc (clamp)) 5 | 6 | (deftest ado (misc) 7 | (assert-eql 338350 (ado (range 1 100) 8 | (map [* _ _] it) 9 | (reduce #'+ it))) 10 | (assert-eql 10 (ado 10))) 11 | 12 | (deftest accum (misc) 13 | (assert-equal (range 1 10) 14 | (accum a 15 | (upto i 1 10 16 | (a i)))) 17 | (assert-equal (map [* _ _] (range 1 10)) 18 | (accum a 19 | (upto i 1 10 20 | (a (* i i)))))) 21 | 22 | (deftest summing (misc) 23 | (assert-eql 5 24 | (summing s 25 | (each x (range 1 10) 26 | (s (even x)))))) 27 | 28 | (deftest multiple (misc) 29 | (assert-true (multiple 10 5)) 30 | (assert-false (multiple 15 2))) 31 | 32 | (deftest check (misc) 33 | (assert-eql 5 (check 5 #'odd 10)) 34 | (assert-eql 10 (check 5 #'even 10))) 35 | 36 | (deftest acheck (misc) 37 | (assert-eql 20 (acheck 20 #'even (+ it 5))) 38 | (assert-eql 25 (acheck 20 #'odd (+ it 5)))) 39 | 40 | (deftest in (misc) 41 | (assert-true (in (+ 1 1) 1 2 3)) 42 | (assert-false (in (+ 1 1) 1 3)) 43 | (assert-true (in (+ 1 1) (+ 1 0) (+ 1 1) (+ 2 1))) 44 | (assert-true (in (+ 1 1) 1 2 (/ 1 0) 3))) 45 | 46 | (deftest cart (misc) 47 | (assert-equal '((a a) (a b) (b a) (b b)) (cart #'list '(a b) '(a b))) 48 | (assert-equal '((a b) (b a)) (cart #'list '(a b) (rem it '(a b)))) 49 | (assert-equal '(1 2 3 4) (cart #'+ '(1 3) '(0 1)))) 50 | 51 | (deftest point (misc) 52 | (assert-eql 10 (point val 53 | (loop for i from 2 to 100 by 2 54 | if (multiple i 5) 55 | do (val i)))) 56 | (assert-eql 10 (point val 57 | (map (fif [multiple _ 5] #'val) 58 | (range 2 100 2))))) 59 | 60 | (deftest roundup (misc) 61 | (assert-eql 5 (roundup 4.6)) 62 | (assert-eql 5 (roundup 5.4)) 63 | (assert-eql 5 (roundup 4.5)) 64 | (assert-eql 6 (roundup 5.5)) 65 | (assert-eql -5 (roundup -4.6)) 66 | (assert-eql -5 (roundup -5.4)) 67 | (assert-eql -5 (roundup -4.5)) 68 | (assert-eql -6 (roundup -5.5))) 69 | 70 | (deftest nearest (misc) 71 | (assert-eql 5 (nearest 4.5 1)) 72 | (assert-eql 5 (nearest 5.4 1)) 73 | (assert-eql 6 (nearest 5.5 1)) 74 | (assert-eql 6 (nearest 4.5 3)) 75 | (assert-eql 3 (nearest 4.4 3)) 76 | ;; I need to rewrite this test since floats are inexact when doing 77 | ;; math with them. 78 | ;; (assert-eql 3.14 (nearest 3.14159265 .01)) 79 | ) 80 | 81 | (deftest before (misc) 82 | (let xs '(1 2 3 4 5) 83 | (assert-true (before 1 2 xs)) 84 | (assert-true (before 4 5 xs)) 85 | (assert-true (before 5 6 xs)) 86 | (assert-false (before 6 7 xs)) 87 | (assert-false (before 2 1 xs)) 88 | (assert-false (before 5 4 xs)) 89 | (assert-false (before 6 5 xs)) 90 | (assert-true (before #'odd #'even xs)) 91 | (assert-false (before #'even #'odd xs)) 92 | (assert-true (before [multiple _ 3] [multiple _ 4] xs)) 93 | (assert-false (before [multiple _ 4] [multiple _ 3] xs)) 94 | (assert-true (before [multiple _ 3] 4 xs)) 95 | (assert-false (before 4 [multiple _ 3] xs)))) 96 | 97 | (deftest calln (misc) 98 | (assert-eql 2 (calln 0 [* _ _] 2)) 99 | (assert-eql 4 (calln 1 [* _ _] 2)) 100 | (assert-eql 16 (calln 2 [* _ _] 2)) 101 | (assert-eql 256 (calln 3 [* _ _] 2))) 102 | -------------------------------------------------------------------------------- /tests/tables-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite tables (clamp)) 5 | 6 | (deftest keys (tables) 7 | (let tab (table) 8 | (assert-equal '() (keys tab)) 9 | (= (gethash 'a tab) 1) 10 | (assert-equal '(a) (keys tab)) 11 | (= (gethash 'b tab) 2) 12 | (assert-true (or (equal '(a b) (keys tab)) 13 | (equal '(b a) (keys tab)))))) 14 | 15 | (deftest vals (tables) 16 | (let tab (table) 17 | (assert-equal '() (vals tab)) 18 | (= (gethash 'a tab) 1) 19 | (assert-equal '(1) (vals tab)) 20 | (= (gethash 'b tab) 2) 21 | (assert-true (or (equal '(1 2) (vals tab)) 22 | (equal '(2 1) (vals tab)))))) 23 | 24 | (deftest listtab (tables) 25 | (withs (tab (listtab '((a 1) (b 2))) 26 | keys (keys tab) 27 | vals (vals tab)) 28 | (assert-true (or (equal '(a b) keys) 29 | (equal '(b a) keys))) 30 | (assert-true (or (equal '(1 2) vals) 31 | (equal '(2 1) vals))) 32 | (assert-eql 1 (gethash 'a tab)) 33 | (assert-eql 2 (gethash 'b tab)))) 34 | 35 | (deftest tablist (tables) 36 | (let alist (tablist (obj a 1 b 2 c 3)) 37 | (assert-eql 1 (alref alist 'a)) 38 | (assert-eql 2 (alref alist 'b)) 39 | (assert-eql 3 (alref alist 'c)))) 40 | 41 | (deftest obj (tables) 42 | (let tab (obj a 1 b 2 c 3) 43 | (assert-eql 1 (gethash 'a tab)) 44 | (assert-eql 2 (gethash 'b tab)) 45 | (assert-eql 3 (gethash 'c tab)))) 46 | 47 | (deftest alref (tables) 48 | (let alist '((a 1) (b 2) (c 3) (d nil)) 49 | (assert-eql 1 (alref alist 'a)) 50 | (assert-eql 2 (alref alist 'b)) 51 | (assert-eql 3 (alref alist 'c)) 52 | (assert-eql 4 (aif2 (alref alist 'd) 53 | 4 54 | 5)) 55 | (assert-eql 5 (aif2 (alref alist 'e) 56 | 4 57 | 5)) 58 | (assert-equal '(1) (alref alist 'a t)) 59 | (assert-equal '(2) (alref alist 'b t)) 60 | (assert-equal '(3) (alref alist 'c t)))) 61 | 62 | (deftest counts (tables) 63 | (let tab (counts '(1 2 3 2 1 2 3 1 2)) 64 | (assert-eql 3 (gethash 1 tab)) 65 | (assert-eql 4 (gethash 2 tab)) 66 | (assert-eql 2 (gethash 3 tab))) 67 | (let tab (counts '((1 2) (3 4) (1 2) (1 3)) :test #'iso) 68 | (assert-eql 2 (gethash '(1 2) tab))) 69 | (let tab (counts '((1 2) (3 4) (1 2 3) (7 8 9)) :key #'len) 70 | (assert-eql 2 (gethash 2 tab)) 71 | (assert-eql 2 (gethash 3 tab))) 72 | (let tab (counts '((1 2 3) (1 3) (7 8 3)) :test #'iso :key [rem #'even _]) 73 | (assert-eql 2 (gethash '(1 3) tab)) 74 | (assert-eql 1 (gethash '(7 3) tab)))) 75 | 76 | (deftest commonest (tables) 77 | (assert-equal '(nil 0) (mvl (commonest '()))) 78 | (assert-equal '(5 3) (mvl (commonest'(1 6 5 2 3 4 5 9 2 8 5 9 0)))) 79 | (assert-equal '(2 2) (mvl (commonest '((1 2) (1 2 3) (3 4) (3 4 5)) 80 | :key #'len))) 81 | (assert-equal '((1 2) 2) (mvl (commonest '((1 2) (1 2 3) (1 2) (3 4)) 82 | :test #'iso))) 83 | (assert-equal '((1 3) 2) (mvl (commonest '((1 2 3) (7 8 3) (1 3)) 84 | :test #'iso 85 | :key [rem #'even _])))) 86 | 87 | (deftest memtable (tables) 88 | (assert-equalp (table) (memtable '())) 89 | ;; The macro obj returns a table that uses equalp. 90 | (assert-equalp (obj a t b t) (memtable '(a b) :test #'equalp)) 91 | (assert-equalp (obj a nil b nil) (memtable '(a b) :val nil :test #'equalp))) 92 | -------------------------------------------------------------------------------- /src/hof.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Higher order funtions. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (def mapv (f seq &rest seqs) 7 | "Map a procedure over the given sequences and return a vector 8 | containing the results." 9 | (apply #'cl:map 'vector f seq seqs)) 10 | 11 | (def testify (x &optional (test #'iso)) 12 | "If passed a procedure, returns it. Otherwise returns a function 13 | which tests equality for the object passed." 14 | (if (functionp x) x [call test x _])) 15 | 16 | (def rem (f xs &rest args &key (test #'iso) &allow-other-keys) 17 | "Equivalent to remove-if but 'testifies' TEST first." 18 | (apply #'remove-if (testify f test) xs :allow-other-keys t args)) 19 | 20 | (def keep (f xs &rest args &key (test #'iso) &allow-other-keys) 21 | "Equivalent to remove-if-not but 'testifies' TEST first." 22 | (apply #'remove-if-not (testify f test) xs :allow-other-keys t args)) 23 | 24 | (def mem (f xs &rest args &key (test #'iso) &allow-other-keys) 25 | "Equivalent to member-if but 'testifies' TEST first." 26 | (apply #'member-if (testify f test) xs :allow-other-keys t args)) 27 | 28 | (def find (f xs &rest args &key (test #'iso) &allow-other-keys) 29 | "Equivalent to find-if but 'testifies' TEST first." 30 | (apply #'find-if (testify f test) xs :allow-other-keys t args)) 31 | 32 | (def count (f xs &rest args &key (test #'iso) &allow-other-keys) 33 | "Equivalent to count-if but 'testifies' TEST first." 34 | (apply #'count-if (testify f test) xs :allow-other-keys t args)) 35 | 36 | (def pos (f xs &rest args &key (test #'iso) &allow-other-keys) 37 | "Equivalent to position-if but 'testifies' TEST first." 38 | (apply #'position-if (testify f test) xs :allow-other-keys t args)) 39 | 40 | (def mappend (f &rest xss) 41 | "Equivalent to map but appends the results instead of just 42 | returning them." 43 | (apply #'join (apply #'map f xss))) 44 | 45 | (def partition (test seq &key (key #'identity) (start 0)) 46 | "Returns two lists, the first one containing all of the elements of 47 | XS that pass the 'testified' version of test and the second 48 | containing all of those that don't." 49 | (loop with f = (testify test) 50 | for x in (cut (coerce seq 'list) start) 51 | if (call f (funcall key x)) 52 | collect x into pass 53 | else 54 | collect x into fail 55 | finally (return (values pass fail)))) 56 | 57 | (def trues (f xs) 58 | "Maps F over XS and returns a list of the non-nil results." 59 | (keep #'idfn (map f xs))) 60 | 61 | (mac hofeach (f var xs &body body) 62 | "Wrap BODY in a anonymous function with argument VAR and call the 63 | higher order function F with that function and XS as arguments." 64 | `(call ,f (fn (,var) ,@body) ,xs)) 65 | 66 | (mac mapeach (var xs &body body) 67 | "Executes BODY repetitively with each element of XS bound to VAR. 68 | Returns a list of the results. VAR can be a destructuring list." 69 | `(loop for ,var in ,xs collect (do ,@body))) 70 | 71 | (mac mappendeach (var xs &body body) 72 | "Executes BODY repetitively with each element of XS bound to VAR. 73 | Returns a list of all of the results appended together. VAR can be 74 | a destructuring list." 75 | `(loop for ,var in ,xs append (do ,@body))) 76 | 77 | (def positions (f seq &key (test #'iso) (key #'idfn)) 78 | "Returns a list of all of the positions of elements in SEQ that 79 | pass TEST." 80 | ;; The macros 'accum' and 'on' are not defined yet. 81 | (loop with fn = (testify f test) 82 | for x in (coerce seq 'list) 83 | for i from 0 84 | if (call fn (call key x)) 85 | collect i)) 86 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | Clamp: Common Lisp with Arc Macros and Procedures 2 | ==== 3 | https://github.com/arclanguage/Clamp 4 | 5 | by Michael Malis (originally at https://github.com/malisper/Clamp) 6 | 7 | Arc is an amazing programming language because of its brevity and succinctness, 8 | but at the same time, it lacks some of the most basic features of a programming 9 | language. It has neither a debugger nor a module system. Common Lisp on the 10 | other hand has many of the fundamentals that Arc lacks and much more (restarts, 11 | reader macros, etc), but lacks the conciseness of Arc. Clamp is an attempt to 12 | bring the powerful, but verbose, language of Common Lisp up to the terseness 13 | of Arc. 14 | 15 | There are currently two parts to Clamp. There is the core of Clamp, which 16 | implements the utilities of Arc that are easily converted from Arc to Common 17 | Lisp. The other part is the 'experimental' part. It contains features of Arc 18 | that are not so easy to copy (ssyntax, argument destructuring, etc). 19 | 20 | The package `:clamp` exports not only the symbols that are new in Clamp, but 21 | also exports most of the symbols from the `:cl` package. This is done so that 22 | it is possible to shadow Common Lisp operators which do different things than 23 | the Arc operators of the same names. By using Clamp in a package, you are 24 | automatically using most of the symbols exported by `:cl` (some, such as 25 | `rplaca`, have not been exported because use of them is generally considered 26 | bad style). 27 | 28 | The package `:clamp-experimental` works a little differently. It only exports 29 | the new symbols it defines. In order to use both `:clamp` and `:clamp-experimental`, 30 | you will have to use both and then handle the conflicts. 31 | 32 | In both packages, a lot of code has been taken from both the original Arc and 33 | Anarki. 34 | 35 | To install Clamp you'll need a Common Lisp implementation. One way is to 36 | install SBCL and the Quicklisp package manager on Linux: 37 | 38 | ```shell 39 | $ sudo apt-get install sbcl # other Common Lisp implementations might work as well 40 | $ wget https://beta.quicklisp.org/quicklisp.lisp # following instructions at https://quicklisp.org 41 | $ sbcl --load quicklisp.lisp 42 | * (quicklisp-quickstart:install) 43 | * (ql:add-to-init-file) 44 | * (quit) 45 | ``` 46 | 47 | (These instructions were tested on Ubuntu 14.04 with sbcl 1.1.14.) 48 | 49 | Now add the Clamp git repository to ~/quicklisp/local-projects. Then you can 50 | start up clamp in three ways: 51 | 52 | a) Run the 'clamp' script in the repo: 53 | 54 | ``` 55 | $ clamp 56 | * (map [+ _ 1] '(1 2 3)) 57 | ``` 58 | 59 | This requires either that you be in ~/quicklisp/local-projects/Clamp, or that 60 | you copy the 'clamp' script somewhere in your PATH. 61 | 62 | b) If you want to run from any directory and don't want to mess with the PATH, 63 | you'll need to type in a few commands into sbcl: 64 | 65 | ``` 66 | $ sbcl 67 | * (ql:quickload :clamp) 68 | * (in-package :clamp) 69 | * (use-syntax :clamp) 70 | ``` 71 | 72 | c) To run Clamp with Emacs, follow the instructions to install MELPA and SLIME 73 | at https://www.common-lisp.net/project/slime/doc/html/Installation.html, and 74 | then add these lines in your .emacs: 75 | 76 | ``` 77 | (setq inferior-lisp-program (concat (getenv "HOME") "/quicklisp/local-projects/Clamp/clamp")) 78 | (add-hook 'lisp-mode-hook (lambda () (slime-mode t))) 79 | ``` 80 | 81 | Either way, you should now be ready to go: 82 | 83 | ``` lisp 84 | * (map [+ _ 1] '(1 2 3)) ; example showing off Arc-specific syntax 85 | (2 3 4) 86 | ``` 87 | 88 | Finally, to run Clamp's unit tests: 89 | 90 | ``` lisp 91 | * (ql:quickload :clamp-tests) 92 | * (in-package :clamp-tests) 93 | * (run-suite 'clamp) 94 | ``` 95 | -------------------------------------------------------------------------------- /experimental/destructuring.lisp: -------------------------------------------------------------------------------- 1 | ;;;; This is an experimental implementation of argument destructuring. 2 | 3 | (in-package :experimental) 4 | (use-syntax :clamp) 5 | 6 | ;;;; Right now this implements a basic form of argument destructuring 7 | ;;;; and allows shorter names for the different kinds of arguments (? 8 | ;;;; for optional arguments, ! for keyword arguments, and an improper 9 | ;;;; argument list is equivalent to one that uses &rest [scheme 10 | ;;;; style]). One can even use a symbol to represent all of the 11 | ;;;; arguments. For example (fn args (reduce #'+ args)) is a procedure 12 | ;;;; which sums its arguments. Even cooler is (fn fn fn) which is 13 | ;;;; equivalent to the list procedure. To use destructuring with 14 | ;;;; optional arguments, they needs to be surrounded by parens, 15 | ;;;; otherwise it is ambigous as to whether (x a) meas that x 16 | ;;;; defaults to the value of a, or this is meant to destructure 17 | ;;;; into variables x and a. 18 | 19 | ;;;; Issues 20 | ;;;; Keyword arguments do not work with destructuring. What would the 21 | ;;;; keyword argument be? Even if one provided a name with the 22 | ;;;; argument the syntax would be pretty complicated to represent it. 23 | ;;;; Also any arguments named by ? or ! will not work. This can be 24 | ;;;; fixed by modifying parse-arguments to work recursively up the 25 | ;;;; argument list ignoring the variable name. Then switching the use 26 | ;;;; of sublis in add-keywords with subst-list. 27 | 28 | (defun subst-list (alist xs) 29 | "Substitutes the corresponding values in ALIST into the list XS." 30 | (map [aif2 (alref alist _) it _] xs)) 31 | 32 | (defun last-atom (xs) 33 | "Returns the last atom of an improper list and everything that 34 | occurs before it." 35 | (rec (cur xs acc '()) 36 | (if (atom cur) 37 | (values cur (rev acc)) 38 | (recur (cdr cur) (cons (car cur) acc))))) 39 | 40 | (defun add-keywords (args) 41 | "Converts symbols such as '?' to their corresponding lambda list 42 | keyword and adds &rest if the lambda list is not a proper list." 43 | ;; We first add the &rest if it is needed, then we substitute all 44 | ;; of the new keywords with the old ones. 45 | (sublis '((? . &optional) 46 | (! . &key)) 47 | (add-rest args))) 48 | 49 | (defun add-rest (args) 50 | "If this arglist is an improper list, convert it into one that uses 51 | &rest." 52 | (check args 53 | #'proper 54 | (mvb (var rest) (last-atom args) 55 | ;; If this is not a proper list, we want to take whatever 56 | ;; is in the tail and add a &rest before it. 57 | (append rest (list '&rest var))))) 58 | 59 | (defun parse-args (args) 60 | "Parses an entire argslist and returns a new argslist, along with an 61 | alist of arguments that need to be destructured." 62 | (withs (key-args (add-keywords args) 63 | pos (pos [mem _ lambda-list-keywords] key-args)) 64 | (if (null pos) 65 | (parse-normal key-args) 66 | (mvb (new-args1 alist1) (parse-normal (cut key-args 0 pos)) 67 | (mvb (new-args2 alist2) (parse-optional (cut key-args (+ pos 1))) 68 | (values (append new-args1 (list (elt key-args pos)) new-args2) 69 | (append alist1 alist2))))))) 70 | 71 | (defun parse-normal (args) 72 | "This parses normal arguments in an argslist." 73 | (loop for arg in args 74 | for g = (uniq) 75 | if (consp arg) 76 | collect g into new-args 77 | and collect (list g arg) into alist 78 | else 79 | collect arg into new-args 80 | finally (return (values new-args alist)))) 81 | 82 | (defun parse-optional (args) 83 | "This parses the optional and keyword arguments in an args." 84 | (loop for arg in args 85 | for g = (uniq) 86 | if (and (consp arg) (consp (car arg))) 87 | collect (cons g (cdr arg)) into new-args 88 | and collect (list g (car arg)) into alist 89 | else 90 | collect arg into new-args 91 | finally (return (values new-args alist)))) 92 | 93 | (defmacro fn (args &body body) 94 | "Same as clamp:fn but allows ?, !, and argument destructuring." 95 | (mvb (new-args alist) (parse-args args) 96 | (if (null alist) 97 | `(lambda ,new-args ,@body) 98 | `(lambda ,new-args 99 | (let ,(map #'cadr alist) (list ,@(map #'car alist)) 100 | ,@body))))) 101 | -------------------------------------------------------------------------------- /tests/iter-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite iter (clamp)) 5 | 6 | (deftest rec (iter) 7 | (assert-eql 55 8 | (rec (n 10) 9 | (if (<= 0 n 1) 10 | n 11 | (+ (recur (- n 1)) 12 | (recur (- n 2)))))) 13 | (assert-eql 120 14 | (rec (n 5) 15 | (if (is n 0) 16 | 1 17 | (* n (recur (- n 1)))))) 18 | (assert-eql 720 19 | (rec (n 6 acc 1) 20 | (if (is n 0) 21 | acc 22 | (recur (- n 1) (* acc n)))))) 23 | 24 | (deftest repeat (iter) 25 | (assert-equal (n-of 10 5) (accum a (repeat 10 (a 5)))) 26 | (assert-eql 1024 (ret result 1 (repeat 10 (zap #'* result 2)))) 27 | (assert-eql 625 (ret result 5 (repeat 2 (zap [* _ _] result)))) 28 | (assert-eql 55 (ret result 0 29 | (let i 0 30 | (repeat 10 31 | (++ i) 32 | (++ result i)))))) 33 | 34 | (deftest up (iter) 35 | (assert-equal (range 1 9) (accum a (up i 1 10 (a i)))) 36 | (assert-eql 45 (ret result 0 (up i 1 10 (++ result i)))) 37 | (assert-eql 20 (ret result 0 (up i 1 6 (++ result i) (++ result))))) 38 | 39 | (deftest upto (iter) 40 | (assert-equal (range 1 10) (accum a (upto i 1 10 (a i)))) 41 | (assert-eql 55 (ret result 0 (upto i 1 10 (++ result i)))) 42 | (assert-eql 20 (ret result 0 (upto i 1 5 (++ result i) (++ result))))) 43 | 44 | (deftest down (iter) 45 | (assert-equal (rev (range 1 9)) (accum a (down i 10 1 (a i)))) 46 | (assert-eql 45 (ret result 0 (down i 10 1 (++ result i)))) 47 | (assert-eql 20 (ret result 0 (down i 6 1 (++ result i) (++ result))))) 48 | 49 | (deftest downfrom (iter) 50 | (assert-equal (rev (range 1 10)) (accum a (downfrom i 10 1 (a i)))) 51 | (assert-eql 55 (ret result 0 (downfrom i 10 1 (++ result i)))) 52 | (assert-eql 20 (ret result 0 (downfrom i 5 1 (++ result i) (++ result))))) 53 | 54 | (deftest while (iter) 55 | (assert-equal '(t t t) (accum a 56 | (fromstring "10 4 6 7 8" 57 | (while (even (read)) 58 | (a t))))) 59 | (assert-eq 100 (ret result 0 60 | (let counter 10 61 | (while (> counter 0) 62 | (++ result 10) 63 | (-- counter 1)))))) 64 | 65 | (deftest until (iter) 66 | (assert-equal '(t t t) (accum a 67 | (fromstring "10 4 6 7 8" 68 | (until (odd (read)) 69 | (a t))))) 70 | (assert-eq 100 (ret result 0 71 | (let counter 10 72 | (until (<= counter 0) 73 | (++ result 10) 74 | (-- counter 1)))))) 75 | 76 | (deftest each (iter) 77 | (assert-equal (map [* _ _] (range 1 10)) 78 | (accum a 79 | (each x (range 1 10) 80 | (a (* x x))))) 81 | (assert-eql 54 82 | (ret result 0 83 | (each x (range 1 9) 84 | (++ result x) 85 | (++ result))))) 86 | 87 | (deftest on (iter) 88 | (assert-equal '((0 a) (1 b) (2 c)) 89 | (accum a 90 | (on x '(a b c) 91 | (a (list index x))))) 92 | (assert-eql 110 93 | (ret result 0 94 | (on x (range 0 10) 95 | (++ result x) 96 | (++ result index))))) 97 | 98 | (deftest whilet (iter) 99 | (assert-equal '(1 2 3) (accum a (fromstring "1 2 3" 100 | (whilet x (read :eof nil) 101 | (a x)))))) 102 | 103 | (deftest whiler (iter) 104 | (assert-equal '(1 2 3) 105 | (accum a (fromstring "1 2 3" 106 | (whiler x (read :eof nil) nil 107 | (a x))))) 108 | (assert-equal '(1 2 3) 109 | (accum a (fromstring "1 2 3" 110 | (whiler x (read :eof t) t 111 | (a x)))))) 112 | 113 | (deftest forlen (iter) 114 | (let xs '(1 2 3) 115 | (assert-equal (rev xs) (ret result '() 116 | (forlen i xs 117 | (push (elt xs i) result))))) 118 | (let seq #(1 2 3) 119 | (assert-equal (rev (coerce seq 'list)) 120 | (ret result '() 121 | (forlen i seq 122 | (push (elt seq i) result)))))) 123 | -------------------------------------------------------------------------------- /src/misc.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Utilities which do not belong in any other file. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (mac ado (&body body) 7 | "Evaluates each expression with the symbol 'it' bound to the result 8 | of the previous one. Returns the value of the last expression." 9 | ;; The special-form let* cannot be used here because it makes it 10 | ;; impossible to declare each 'it' ignorable. So if one expression 11 | ;; does not use 'it', a warning would be given. 12 | (if (null body) 13 | nil 14 | (single body) 15 | (car body) 16 | :else 17 | `(let it ,(car body) 18 | (declare (ignorable it)) 19 | (ado ,@(cdr body))))) 20 | 21 | (mac accum (accfn &body body) 22 | "Binds ACCFN to a procedure which will accumulate values. The result 23 | of accum is all of the elements passed to ACCFN in the same 24 | order." 25 | (w/uniq (ghead gtail) 26 | `(withs (,ghead (list nil) ,gtail ,ghead) 27 | (flet1 ,accfn (arg) (= ,gtail (= (cdr ,gtail) (list arg))) 28 | ,@body 29 | (cdr ,ghead))))) 30 | 31 | (mac summing (sumfn &body body) 32 | "Binds SUMFN to a procudure which will counts every time it is 33 | passed a non-nil value. The result of summing is the number of 34 | times that procedure is called." 35 | (w/uniq gacc 36 | `(ret ,gacc 0 37 | (flet1 ,sumfn (arg) (when arg (++ ,gacc)) 38 | ,@body)))) 39 | 40 | (def multiple (x y) 41 | "Is X a multiple of Y?" 42 | (zerop (mod x y))) 43 | 44 | (mac check (x test &optional alt) 45 | "If X passes TEST (not testified) return it, otherwise evaluate 46 | ALT." 47 | (w/uniq val 48 | `(let ,val ,x 49 | (if (call ,test ,val) 50 | ,val 51 | ,alt)))) 52 | 53 | (mac acheck (x test &optional alt) 54 | "If X passes TEST (not testified) return it, otherwise bind 'it' to 55 | the result of X and evaluate ALT." 56 | `(let it ,x 57 | (if (call ,test it) 58 | it 59 | ,alt))) 60 | 61 | (mac in (x &rest choices) 62 | "Returns t if X is one of the results of evaluating every CHOICE 63 | (lazily)." 64 | (if (single choices) 65 | ;; If there is a single choice, this is most likely part of an 66 | ;; iterate clause. 67 | `(iter:in ,x ,@choices) 68 | (w/uniq val 69 | `(let ,val ,x 70 | (or ,@(map (fn (c) `(is ,val ,c)) choices)))))) 71 | 72 | (mac cart (f xs ys) 73 | "Applies F to a variation of the cartesian product of XS and YS. 74 | While going through XS, every element is bound to 'it' which 75 | can be used to modify YS." 76 | (w/uniq y 77 | `(mapcan (fn (it) ; It is okay to use mapcan since map conses. 78 | (map (fn (,y) 79 | (call ,f it ,y)) 80 | ,ys)) 81 | ,xs))) 82 | 83 | (def rand-elt (seq) 84 | "Returns a random element from SEQ." 85 | (elt seq (rand (len seq)))) 86 | 87 | (mac rand-choice (&rest exprs) 88 | "Randomly evaluates one of the expressions in EXPRS." 89 | `(case (rand ,(len exprs)) 90 | ,@(mappend #'list 91 | (range 0 (- (len exprs) 1)) 92 | exprs))) 93 | 94 | (mac point (name &body body) 95 | "Defines a procedure which when called on a value, the value of 96 | this expression will immediately become that value. The procedure 97 | will only return up the stack, it is not the same as a 98 | continuation." 99 | (w/uniq here 100 | `(block ,here 101 | (flet1 ,name (arg) (return-from ,here arg) 102 | ,@body)))) 103 | 104 | (mac defs (&body args) 105 | "Defines multiple procedures all in the same form." 106 | `(do ,@(mapeach proc (group args :by 3) 107 | `(def ,@proc)))) 108 | 109 | (def roundup (n) 110 | "Rounds the argument to the nearest number. Rounds halves away from 111 | zero." 112 | (mvb (base rem) (trunc n) 113 | (if (>= (abs rem) 1/2) 114 | (if (positive n) 115 | (inc base) 116 | (dec base)) 117 | base))) 118 | 119 | (def nearest (n quantum) 120 | "Rounds N to the closest multiple of QUANTUM. Halves are rounded 121 | way from zero." 122 | (* (roundup (/ n quantum)) quantum)) 123 | 124 | ;; The procedure 'before' cannot be defined in hof because it uses orf 125 | ;; which is defined in fnops. 126 | 127 | (def before (x y seq) 128 | "Does X occur before Y in SEQ? The values passed in for X and Y are 129 | testified, so they can be either objects or predicates." 130 | (with (xtest (testify x) ytest (testify y)) 131 | (aand (find (orf xtest ytest) seq) 132 | (call xtest it)))) 133 | 134 | (def calln (n f x) 135 | "Calls the function F, N times on X." 136 | (if (is n 0) 137 | x 138 | (calln (dec n) f (call f x)))) 139 | -------------------------------------------------------------------------------- /experimental/ssyntax.lisp: -------------------------------------------------------------------------------- 1 | ;;;; This is an experimental implementation of ssyntax. 2 | 3 | (in-package :experimental) 4 | (use-syntax :clamp) 5 | 6 | ;;;; By surrounding code with the w/ssyntax macro, ssyntax is 7 | ;;;; transformed into the corresponding code. To implement your own 8 | ;;;; ssyntax, use the defssyntax-test, defssyntax-sym-mac, and 9 | ;;;; defssyntax-macro. 10 | 11 | ;;;; The macro defssyntax-test is used to define a predicate which can 12 | ;;;; detect the different versions of ssyntax. The macros 13 | ;;;; defssyntax-sym-mac and defssyntax-macro and used to define 14 | ;;;; procedures which will expand the actual ssyntax. Use 15 | ;;;; defssyntax-sym-mac to define a procedure which will expand any 16 | ;;;; form that is not in the operator position. You must write a 17 | ;;;; procedure which can generate symbol-macrolet binding to be used 18 | ;;;; to expand the ssyntax. Ultimately this winds up being a list with 19 | ;;;; the first element being the symbol (the one that contains 20 | ;;;; ssyntax) and the desired transformation. The macro 21 | ;;;; defssyntax-macro is used to define a procedure which will expand 22 | ;;;; any ssyntax that is in the operator position. To use it, you need 23 | ;;;; to write a procedure which will generate a macro definition 24 | ;;;; (whose name is the symbol which contains the ssyntax) and whose 25 | ;;;; expansion will yield the desired transformation. If you are 26 | ;;;; confused just look at some of the examples below. 27 | 28 | ;;;; A procedure defined using any of the above methods must take in 29 | ;;;; two arguments. The first one will be the symbol that potentially 30 | ;;;; contains ssyntax. The second argument (provided for convenience) 31 | ;;;; is a string of the name of the symbol. 32 | 33 | ;;;; ISSUES 34 | ;;;; Using multiple ssyntax in the same symbol will expand in an 35 | ;;;; unpredictable way. Additionally the ssyntax for composition (+) 36 | ;;;; detects procedures such as 1+ and +. To get around this I used a 37 | ;;;; simple hack of testing that the length of the symbol is greater 38 | ;;;; than two for ssyntax for composition. Also there is no way to 39 | ;;;; specify ssyntax where any of the procedures used in the ssyntax 40 | ;;;; are stored in variables, for example: 41 | 42 | ;;;; (let f (fn (x) (+ x 10)) (list+f 20)) 43 | 44 | ;;;; will look for the function f, not the variable. 45 | 46 | (defmacro w/ssyntax (&body body) 47 | "Allows BODY to use ssyntax." 48 | (let syms (keep #'ssyntax (redup (keep #'symbolp (flat body)))) 49 | `(macrolet ,(trues #'ssyntax-macro syms) 50 | (symbol-macrolet ,(trues #'ssyntax-sym-mac syms) 51 | ,@body)))) 52 | 53 | (defparameter ssyntax-tests* '() 54 | "A list of fns used to test for ssyntax.") 55 | 56 | (defparameter ssyntax-sym-macs* (table) 57 | "A table of fns used to transform ssyntax sym-macs into regular 58 | syntax.") 59 | 60 | (defparameter ssyntax-macros* (table) 61 | "A table of fns used to transform ssyntax macros into regular 62 | syntax.") 63 | 64 | (defun ssyntax (sym) 65 | "Does this contain ssyntax? If it does, the return value is the 66 | name of the kind of ssyntax." 67 | (find [call _ sym (symbol-name sym)] 68 | ssyntax-tests* :key #'cadr)) 69 | 70 | (defparameter errstr* "Wrong number of arguments in definition for ~ 71 | ~A in ~2&~A~2&~A supplied, ~A~@[ to ~A~] ~ 72 | expected.") 73 | 74 | (defmacro defssyntax-test (&whole form name args &body body) 75 | "Defines a new test to detect ssyntax of the kind NAME." 76 | (check-len name form args 2 :str errstr*) 77 | `(push (list ',name (fn ,args ,@body)) 78 | ssyntax-tests*)) 79 | 80 | (defmacro defssyntax-sym-mac (&whole form name args &body body) 81 | "Defines how to get the symbol-macrolet binding for the NAME kind 82 | of ssyntax." 83 | (check-len name form args 2 :str errstr*) 84 | `(= (gethash ',name ssyntax-sym-macs*) 85 | (fn ,args ,@body))) 86 | 87 | (defmacro defssyntax-macro (&whole form name args &body body) 88 | "Defines how to get the macrolet binding for this kind of ssyntax." 89 | (check-len name form args 2 :str errstr*) 90 | `(= (gethash ',name ssyntax-macros*) 91 | (fn ,args ,@body))) 92 | 93 | (defun ssyntax-sym-mac (sym) 94 | "Given a symbol that has ssyntax, returns the symbol-macrolet binding 95 | for it to be transformed into what it is supposed to be." 96 | (aand (ssyntax sym) 97 | (gethash (car it) ssyntax-sym-macs*) 98 | (call it sym (symbol-name sym)))) 99 | 100 | (defun ssyntax-macro (sym) 101 | "Given a symbol that has ssyntax, returns the macrolet definition for 102 | it to be a macro and expand correctly." 103 | (aand (ssyntax sym) 104 | (gethash (car it) ssyntax-macros*) 105 | (call it sym (symbol-name sym)))) 106 | -------------------------------------------------------------------------------- /tests/conditionals-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite conditionals (clamp)) 5 | 6 | (deftest iflet (conditionals) 7 | (assert-eql 15 (iflet x 5 (+ x 10))) 8 | (assert-eql 10 (iflet x nil 5 10)) 9 | (assert-eql 12 (iflet x (find #'even '(1 6 3 7)) (* x 2))) 10 | (assert-eql 10 (iflet x (find #'even '(1 3 7)) (+ 1 1) (+ 5 5))) 11 | (assert-equal '(5 10) (iflet (x . y) (cons 5 10) (list x y))) 12 | (assert-equal '(5 10) 13 | (iflet (x . y) nil 10 (list 5 10) (cons x y))) 14 | (assert-false (iflet nil nil nil nil)) 15 | (assert-false (iflet x (gethash 'a (obj a nil)) (list x)))) 16 | 17 | (deftest whenlet (conditionals) 18 | (assert-false (whenlet x nil 5)) 19 | (assert-eql 15 (whenlet (x . y) (cons 5 10) (+ x y))) 20 | (assert-eql 70 (whenlet x (+ 5 10) (+ 15 20) (+ 30 40)))) 21 | 22 | (deftest aif (conditionals) 23 | (assert-false (aif nil t)) 24 | (assert-eql 5 (aif nil t 5)) 25 | (assert-eql 5 (aif 5 it)) 26 | (assert-eql 15 (aif 10 (+ it 5))) 27 | (assert-eql 30 (aif nil (+ it 5) 10 (+ it 20))) 28 | (assert-eql 15 (aif nil (+ it 5) nil (+ it 20) 15))) 29 | 30 | (deftest awhen (conditionals) 31 | (assert-false (awhen nil t)) 32 | (assert-eql 24 (awhen (find #'even '(7 5 4 3)) (+ it 20))) 33 | (assert-false (awhen (find #'even '(7 5 3)) (+ it 20))) 34 | (assert-eql 35 (awhen (find #'even '(7 5 4 3)) (+ 5 10) (+ 15 20)))) 35 | 36 | (deftest aand (conditionals) 37 | (assert-false (aand nil)) 38 | (assert-false (aand t nil)) 39 | (assert-false (aand t nil t)) 40 | (let tab (obj a (obj a 1 b 2) b (obj a 1 b 2) c nil) 41 | (assert-eql 2 (aand (gethash 'a tab) (gethash 'b it))) 42 | (assert-false (aand (gethash 'd tab) (gethash 'b it))) 43 | (assert-false (aand (gethash 'c tab) (list it))))) 44 | 45 | (deftest or2 (conditionals) 46 | (let tab (obj a nil b t) 47 | (assert-equal '(nil t) (mvl (or2 (gethash 'x tab) (gethash 'a tab)))) 48 | (assert-eql 10 (or2 (gethash 'x tab) 10)))) 49 | 50 | (deftest aand2 (conditionals) 51 | (assert-false (aand2 nil)) 52 | (assert-false (aand2 t nil)) 53 | (assert-false (aand2 t nil t)) 54 | (let tab (obj a (obj a 1 b 2) b (obj a 1 b 2) c nil) 55 | (assert-eql 2 (aand2 (gethash 'a tab) (gethash 'b it))) 56 | (assert-false (aand2 (gethash 'd tab) (gethash 'b it))) 57 | (assert-equal '(()) (aand2 (gethash 'c tab) (list it))))) 58 | 59 | (deftest iflet2 (conditionals) 60 | (assert-eql 15 (iflet2 x 5 (+ x 10))) 61 | (assert-eql 10 (iflet2 x nil 5 10)) 62 | (assert-eql 12 (iflet2 x (find #'even '(1 6 3 7)) (* x 2))) 63 | (assert-eql 10 (iflet2 x (find #'even '(1 3 7)) (+ 1 1) (+ 5 5))) 64 | (assert-equal '(5 10) (iflet2 (x . y) (cons 5 10) (list x y))) 65 | (assert-equal '(5 10) 66 | (iflet2 (x . y) nil 10 (list 5 10) (cons x y))) 67 | (assert-false (iflet2 nil nil nil nil)) 68 | (assert-equal '(()) (iflet2 x (gethash 'a (obj a nil)) (list x)))) 69 | 70 | (deftest aif2 (conditionals) 71 | (assert-false (aif2 nil (+ 5 5))) 72 | (assert-eql 7 (aif2 (find #'even '(15 2 7 8)) (+ it 5))) 73 | (let tab (obj a nil b 5) 74 | (assert-eql 15 (aif2 (gethash 'b tab) (+ it 10))) 75 | (assert-true (aif2 (gethash 'a tab) (not it))) 76 | (assert-false (aif2 (gethash 'c tab) (not it))))) 77 | 78 | (deftest case (conditionals) 79 | (assert-false (case 'c a 1 b 2)) 80 | (assert-eql 1 (case 'a a 1 b 2)) 81 | (assert-eql 1 (case 'b (a b) 1 c 2)) 82 | (assert-eql 3 (case 'c a 1 b 2 t 3)) 83 | (assert-false (case 'c a 1 b 2 (t) 3)) 84 | (assert-eql 3 (case t a 1 b 2 (t) 3 t 4))) 85 | 86 | ;; The macros ecase and ccase don't accept a default clause. 87 | (deftest ecase (conditionals) 88 | (assert-eql 1 (ecase 'a a 1 b 2)) 89 | (assert-eql 1 (ecase 'b (a b) 1 c 2))) 90 | 91 | (deftest ccase (conditionals) 92 | (assert-eql 1 (let x 'a (ccase x a 1 b 2))) 93 | (assert-eql 1 (let x 'b (ccase x (a b) 1 c 2)))) 94 | 95 | (deftest caselet (conditionals) 96 | (assert-eql 5 97 | (caselet x 10 98 | 10 5 99 | 20 30 100 | t x)) 101 | (assert-eql 30 102 | (caselet x 20 103 | 10 5 104 | 20 30 105 | t x)) 106 | (assert-eql 50 107 | (caselet x 50 108 | 10 5 109 | 20 30 110 | t x))) 111 | 112 | (deftest typecase (conditionals) 113 | (assert-true 114 | (typecase 5 115 | number t 116 | t nil)) 117 | (assert-false 118 | (typecase nil 119 | number t 120 | t nil))) 121 | 122 | (deftest switchlet (conditionals) 123 | (assert-eql 1 124 | (switchlet x 10 125 | (+ 5 10) (- x 10) 126 | (+ 5 5) (- x 9))) 127 | (assert-eql 400 128 | (with (x 10 y 10) 129 | (switchlet z (+ x y) 130 | (- x y) z 131 | (= x 15) 19 132 | (+ x 5) (* z z))))) 133 | 134 | (deftest switch (conditionals) 135 | (assert-eql 1 136 | (switch 10 137 | (+ 5 10) 2 138 | (+ 5 5) 1)) 139 | (assert-eql 400 140 | (with (x 10 y 10) 141 | (switch (+ x y) 142 | (- x y) 0 143 | (= x 15) 19 144 | (+ x 5) 400)))) 145 | -------------------------------------------------------------------------------- /src/conditionals.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are utilities for conditional branching. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (mac iflet (var &body branches) 7 | "Same as clamp:if but if a predicate is true, the value of predicate 8 | is bound to VAR in the corresponding branch." 9 | (if (no branches) 10 | nil 11 | (single branches) 12 | (car branches) 13 | :else 14 | (w/uniq val 15 | ;; Since the list has at least two elements, the first one 16 | ;; is the test and the second is the expr to evaluate if 17 | ;; the test returns true. 18 | (let (test expr . rest) branches 19 | ;; A uniq needs to be used in case VAR is dynamically scoped. 20 | `(let ,val ,test 21 | (if ,val 22 | (let ,var ,val 23 | (declare (ignorable ,@(flat var))) 24 | ,expr) 25 | (iflet ,var ,@rest))))))) 26 | 27 | (mac whenlet (var expr &body body) 28 | "If EXPR returns non-nil, bind that value to VAR and execute body." 29 | `(iflet ,var ,expr (do ,@body))) 30 | 31 | (mac aif (expr &body branches) 32 | "Equivalent to iflet but automatically binds EXPR to 'it'." 33 | `(iflet it ,expr ,@branches)) 34 | 35 | (mac awhen (expr &body body) 36 | "Equivalent to whenlet but automatically binds the value of EXPR 37 | to 'it'." 38 | `(whenlet it ,expr ,@body)) 39 | 40 | (mac aand (&rest args) 41 | "Equivalent to and, but binds the value of the previous expr to 42 | 'it'." 43 | (if (no args) 44 | t 45 | (no (cdr args)) 46 | (car args) 47 | :else 48 | `(let it ,(car args) 49 | (declare (ignorable it)) 50 | (and it (aand ,@(cdr args)))))) 51 | 52 | (mac or2 (&rest args) 53 | "Equivalent to or, but considers something to be true if either its 54 | first value is true, or its second. The first two values of the 55 | first thing considered true will be returned." 56 | (if (no args) 57 | nil 58 | (single args) 59 | (car args) 60 | :else 61 | (w/uniq (val win) 62 | `(mvb (,val ,win) ,(car args) 63 | (if (or ,val ,win) 64 | (values ,val ,win) 65 | (or2 ,@(cdr args))))))) 66 | 67 | (mac iflet2 (var &rest branches) 68 | "Equivalent to iflet, but will also execute the corresponding branch 69 | if the predicate has a second return value which is non-nil. This 70 | is useful for accessing hashtables." 71 | (if (no branches) 72 | nil 73 | (single branches) 74 | (car branches) 75 | :else 76 | (w/uniq (val win) 77 | ;; Since the list has at least two elements, the first one 78 | ;; is the test and the second is the expr to evaluate if 79 | ;; the test returns true. 80 | (let (test expr . rest) branches 81 | ;; A uniq needs to be used in case VAR is dynamically scoped. 82 | `(mvb (,val ,win) ,test 83 | (if (or ,val ,win) 84 | (let ,var ,val 85 | (declare (ignorable ,@(flat var))) 86 | ,expr) 87 | (iflet2 ,var ,@rest))))))) 88 | 89 | (mac aif2 (&rest clauses) 90 | "Equivalent to aif, but will also execute the corresponding branch 91 | if the predicate has a second return value which is non-nil. This 92 | is useful for accessing hashtables." 93 | `(iflet2 it ,@clauses)) 94 | 95 | (mac aand2 (&rest exps) 96 | "Equivalent to and, but binds the value of the previous expr to 97 | 'it' and this considers a non-nil second return value to be true." 98 | (if (no exps) 99 | t 100 | (no (cdr exps)) 101 | (car exps) 102 | :else 103 | (w/uniq (val win) 104 | `(mvb (,val ,win) ,(car exps) 105 | (and (or ,val ,win) 106 | (let it ,val 107 | (declare (ignorable it)) 108 | (aand2 ,@(cdr exps)))))))) 109 | 110 | (mac case (keyform &rest clauses) 111 | "Equivalent to cl:case except there are no parens around each 112 | clause." 113 | `(cl:case ,keyform ,@(group clauses))) 114 | 115 | (mac ccase (keyform &rest clauses) 116 | "Equivalent to cl:ccase except there are no parens around each 117 | clause. 118 | WARNING: do not use :else as the default case, that means to 119 | test for the symbol :else. Instead you have to use t." 120 | `(cl:ccase ,keyform ,@(group clauses))) 121 | 122 | (mac ecase (keyform &rest clauses) 123 | "Equivalent to cl:ecase except there are no parens around each 124 | clause. 125 | WARNING: do not use :else as the default case, that means to 126 | test for the symbol :else. Instead you have to use t." 127 | `(cl:ecase ,keyform ,@(group clauses))) 128 | 129 | (mac caselet (var val &rest clauses) 130 | "The result of VAL is assigned to VAR and then it is compared 131 | against each case clause. 132 | WARNING: do not use :else as the default case, that means to 133 | test for the symbol :else. Instead you have to use t." 134 | `(let ,var ,val 135 | (case ,var 136 | ,@clauses))) 137 | 138 | (mac typecase (keyform &rest clauses) 139 | "Equivalent to cl:typecase but does not require parens around each 140 | clause. 141 | WARNING: do not use :else as the default case, that means to 142 | test for the symbol :else. Instead you have to use t." 143 | `(cl:typecase ,keyform ,@(group clauses))) 144 | 145 | (mac switchlet (var expr &rest cases) 146 | "Similar to caselet, except the expressions being compared against 147 | are evaluated (lazily)." 148 | `(let ,var ,expr 149 | ,(rec (args cases) 150 | (if (no args) 151 | '() 152 | (single args) 153 | (car args) 154 | :else 155 | `(if (is ,var ,(car args)) 156 | ,(cadr args) 157 | ,(recur (cddr args))))))) 158 | 159 | (mac switch (expr . cases) 160 | "Similar to case except the expressions being compared against are 161 | evaluated (lazily)." 162 | `(switchlet ,(uniq) ,expr ,@cases)) 163 | -------------------------------------------------------------------------------- /tests/list-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite list (clamp)) 5 | 6 | (deftest mklist (list) 7 | (assert-true (check-it (generator (or (integer) (list (integer)))) 8 | [listp (mklist _)])) 9 | (assert-true (check-it (generator (or (integer) (list (integer)))) 10 | [let result (mklist _) 11 | (or (is result _) 12 | (is (car result) _))]))) 13 | 14 | (deftest dotted (list) 15 | (assert-false (dotted '())) 16 | (assert-true (dotted '(1 2 . 3))) 17 | (assert-false (dotted '(1 2 3)))) 18 | 19 | (deftest proper (list) 20 | (assert-true (proper '())) 21 | (assert-false (proper '(1 2 . 3))) 22 | (assert-true (proper '(1 2 3)))) 23 | 24 | (deftest range (list) 25 | (assert-true (check-it (generator (list (integer 0) :length 2)) 26 | (lambda (x) 27 | (let (a b) x 28 | (is (length (range a b)) (inc (abs (- a b)))))))) 29 | (assert-true (check-it (generator (tuple (integer 0) (integer 0) (integer 1))) 30 | (lambda (x) 31 | (let (a b c) x 32 | (is (length (range a b c)) (inc (floor (abs (- a b)) c))))))) 33 | (assert-equal '(5 4) (range 5 4)) 34 | (assert-equal '(2 4 6 8 10) (range 2 10 2)) 35 | (assert-equal '(1 3 5 7 9) (range 1 10 2)) 36 | (assert-equal '(5 4 3 2 1) (range 5 1)) 37 | (assert-equal '(10 8 6 4 2) (range 10 2 2)) 38 | (assert-equal '(10 8 6 4 2) (range 10 1 2))) 39 | 40 | (deftest firstn (list) 41 | (assert-equal '(1 2 3) (firstn 3 (range 1 5))) 42 | (assert-equal nil (firstn 0 (range 1 5))) 43 | (assert-equal (range 1 5) (firstn nil (range 1 5))) 44 | (assert-equal (range 1 5) (firstn 10 (range 1 5))) 45 | (assert-equal (range 1 5) (firstn 5 (vector 1 2 3 4 5 6 7 8))) 46 | (assert-equal (range 1 5) (firstn 10 (vector 1 2 3 4 5)))) 47 | 48 | (deftest split (list) 49 | (assert-equal '(() ()) (mvl (split '() 0))) 50 | (assert-equal '(() (a b c)) (mvl (split '(a b c) 0))) 51 | (assert-equal '((a) (b c)) (mvl (split '(a b c) 1))) 52 | ;; Same tests but for vectors. 53 | (assert-equalp '(#() #()) (mvl (split #() 0))) 54 | (assert-equalp '(#() #(a b c)) (mvl (split #(a b c) 0))) 55 | (assert-equalp '(#(a) #(b c)) (mvl (split #(a b c) 1)))) 56 | 57 | (deftest group (list) 58 | (assert-equal '() (group '())) 59 | (assert-equal '() (group '() :by 3)) 60 | (assert-equal '() (group '() :with #'+)) 61 | (assert-equal '((1 2) (3 4)) (group '(1 2 3 4))) 62 | (assert-equal '((1 2) (3 4) (5)) (group (range 1 5))) 63 | (assert-equal '((1 2 3) (4 5)) (group (range 1 5) :by 3)) 64 | (assert-equal '(6 9) (group (range 1 5) :by 3 :with #'+)) 65 | (assert-equal '(3 7 11) (group (range 1 6) :with #'+))) 66 | 67 | (deftest last (list) 68 | (assert-eql 10 (last (range 1 10))) 69 | (assert-eql 'c (last '(a b c)))) 70 | 71 | (deftest flat (list) 72 | (assert-equal (range 1 5) (flat '(((1) 2) (3 4) 5))) 73 | (assert-equal (range 1 5) (flat (range 1 5))) 74 | (assert-equal (range 1 5) (flat '(((1 2 3 4 5)))))) 75 | 76 | (deftest len< (list) 77 | (assert-true (len< '(1 2 3) 4)) 78 | (assert-false (len< '(1 2 3) 3) 79 | (assert-false (len< '(1 2 3) 2)))) 80 | 81 | (deftest len> (list) 82 | (assert-true (len> '(1 2 3) 2)) 83 | (assert-false (len> '(1 2 3) 3)) 84 | (assert-false (len> '(1 2 3) 4))) 85 | 86 | (deftest n-of (list) 87 | (assert-equal '(1 1 1) (n-of 3 1)) 88 | (let x 0 89 | (assert-equal (range 1 5) (n-of 5 (incf x))))) 90 | 91 | (deftest drain (list) 92 | (assert-equal '((1 2) (3 4)) 93 | (w/instring in "(1 2) (3 4)" 94 | (drain (read :from in :eof nil)))) 95 | (assert-equal '(128 64 32 16 8 4 2) 96 | (let x 256 97 | (drain (= x (/ x 2)) 1))) 98 | (assert-equal '(100 50) 99 | (let x 200 100 | (drain (= x (/ x 2)) #'odd)))) 101 | 102 | (deftest caris (list) 103 | (assert-false (caris 5 5)) 104 | (assert-false (caris '(1 2 3) 2)) 105 | (assert-true (caris '(1 2 3) 1))) 106 | 107 | (deftest carif (list) 108 | (assert-eql 5 (carif 5)) 109 | (assert-eql 1 (carif '(1 2 3)))) 110 | 111 | (deftest consif (list) 112 | (assert-equal '(1 2 3) (consif 1 '(2 3))) 113 | (assert-equal '(2 3) (consif nil '(2 3)))) 114 | 115 | (deftest conswhen (list) 116 | (assert-equal '(1 2 3) (conswhen #'idfn 1 '(2 3))) 117 | (assert-equal '(2 3) (conswhen #'even 1 '(2 3))) 118 | (assert-equal '(1 2 3) (conswhen #'odd 1 '(2 3)))) 119 | 120 | (deftest cars (list) 121 | (assert-equal '() (cars '())) 122 | (assert-equal '(1 4 7) (cars '((1 2 3) (4 5 6) (7 8 9))))) 123 | 124 | (deftest cdrs (list) 125 | (assert-equal '() (cdrs '())) 126 | (assert-equal '((2 3) (5 6) (8 9)) (cdrs '((1 2 3) (4 5 6) (7 8 9))))) 127 | 128 | (deftest get (list) 129 | (assert-eql 1 (get '(1 2 3) 0)) 130 | (assert-eql 2 (get '(1 2 3) 1)) 131 | (assert-eql 3 (get '(1 2 3) 2)) 132 | (let xs (list 1 2 3) 133 | (setf (get xs 1) 5) 134 | (assert-eql 5 (get xs 1))) 135 | (assert-eql 1 (get #(1 2 3) 0)) 136 | (assert-eql 2 (get #(1 2 3) 1)) 137 | (assert-eql 3 (get #(1 2 3) 2)) 138 | (let seq (vector 1 2 3) 139 | (setf (get seq 1) 5) 140 | (assert-eql 5 (get seq 1))) 141 | (let tab (obj a 1 b 2) 142 | (assert-eql 1 (get tab 'a)) 143 | (assert-eql 2 (get tab 'b)) 144 | (= (get tab 'a) 3) 145 | (assert-eql 3 (get tab 'a))) 146 | (assert-eql 1 (get '(1 2 3) 'car)) 147 | (assert-equal '(2 3) (get '(1 2 3) 'cdr)) 148 | (let array #2a ((1 2) (3 4)) 149 | (assert-equalp #(1 2) (get array 0)) 150 | (assert-equalp #(3 4) (get array 1)) 151 | (assert-eql 3 (get (get array 1) 0)))) 152 | 153 | (deftest trav (list) 154 | (assert-equal '(1 2 3 4) (accum a (trav '(4 3 2 1) [recur (cdr _)] 155 | [a (car _)]))) 156 | (assert-equal '(1 2 3 4 5 6) (trav '(((1) 2) (3) (4 (5) 6)) 157 | [if (null _) 158 | '() 159 | (atom _) 160 | (list _) 161 | :else 162 | (append (recur (car _)) 163 | (recur (cdr _)))]))) 164 | 165 | (deftest intersperse (list) 166 | (assert-equal '() (intersperse 0 ())) 167 | (assert-equal '(1) (intersperse 0 '(1))) 168 | (assert-equal '(1 0 2 0 3 0 4 0 5) (intersperse 0 (range 1 5)))) 169 | -------------------------------------------------------------------------------- /src/list.lisp: -------------------------------------------------------------------------------- 1 | ;;;; These are utilities for working with lists. 2 | 3 | (in-package :clamp) 4 | (use-syntax :clamp) 5 | 6 | (def mklist (x) 7 | "If X is a list, return it. Otherwise return a list containing X." 8 | (if (listp x) x (list x))) 9 | 10 | (def dotted (x) 11 | "Is this a dotted list?" 12 | (and (listp x) 13 | (rec (rest x) 14 | (if (null rest) 15 | nil 16 | (or (atom rest) 17 | (recur (cdr rest))))))) 18 | 19 | (def proper (x) 20 | "Is this a proper list?" 21 | (and (listp x) 22 | (not (dotted x)))) 23 | 24 | (def range (a b &optional (by 1)) 25 | "Returns a list of numbers from A to B (inclusive) in steps of BY. 26 | The argument BY has to be a positive integer." 27 | ;; The loop macro generates code that is more efficent than what 28 | ;; should be written by hand. 29 | (if (< a b) 30 | (loop for i from a to b by by collect i) 31 | (loop for i downfrom a to b by by collect i))) 32 | 33 | (def firstn (n seq) 34 | "Returns a list of the first N elements of the sequence SEQ or a 35 | list of all the elements if SEQ is too short. If N is nil, returns 36 | the entire sequence." 37 | (if (no n) 38 | seq 39 | (loop repeat n 40 | ;; Cannot use cut to access the the elements because 41 | ;; this should not throw an error when the sequence 42 | ;; is too short. 43 | for x in (coerce seq 'list) 44 | collect x))) 45 | 46 | (def split (seq n) 47 | "Given a sequence and an integer will return two sequences. The first 48 | one will contain the first N elements of the sequence, and the second 49 | will contain the rest of the elements of the initial sequence. The 50 | return sequences are of the same type as the sequence passed in." 51 | (values (cut seq 0 n) (cut seq n))) 52 | 53 | (def group (xs &key (by 2) (with #'list)) 54 | "Groups every BY elements of the given list using the procedure 55 | WITH." 56 | (if (no xs) 57 | '() 58 | (cons (apply with (firstn by xs)) 59 | (group (nthcdr by xs) :by by :with with)))) 60 | 61 | (def last (xs) 62 | "Returns the last element of XS. Not the last cons pair." 63 | (car (lastcons xs))) 64 | 65 | (def flat (tree) 66 | "Returns a list of all of the atoms in a tree (not including nil)" 67 | (rec (left tree acc '()) 68 | (if (null left) 69 | acc 70 | (atom left) 71 | (cons left acc) 72 | :else 73 | (recur (car left) 74 | (recur (cdr left) 75 | acc))))) 76 | 77 | ;;; These are predicates for testing the length of sequences. They may 78 | ;;; be further optimized, but benchmarks would be needed before then. 79 | 80 | (def len< (seq n) 81 | "Is this sequence shorter than some length?" 82 | (< (len seq) n)) 83 | 84 | (def len> (seq n) 85 | "Is this sequence longer than some length?" 86 | (> (len seq) n)) 87 | 88 | (mac n-of (n exp) 89 | "Returns a list containing the results of evaluating EXP, N times." 90 | ;; Loop generates faster code than what I would write by hand. 91 | `(loop repeat ,n collect ,exp)) 92 | 93 | (mac drain (exp &optional (endval nil)) 94 | "Repeatedly evaluates EXP until it passes the testified version of 95 | ENDVAL. Then returns a list of the results." 96 | (w/uniq (gval gtest) 97 | `(loop with ,gtest = (testify ,endval) 98 | for ,gval = ,exp 99 | until (call ,gtest ,gval) 100 | collect ,gval))) 101 | 102 | (def caris (x val) 103 | "Is X a cons pair, and is its car the given value?" 104 | (and (consp x) (is (car x) val))) 105 | 106 | (def carif (x) 107 | "Returns X if it is an atom, otherwise returns (car X)." 108 | (if (atom x) 109 | x 110 | (car x))) 111 | 112 | (def conswhen (f x y) 113 | "Cons X and Y if (F X) is non-nil. Otherwise return Y." 114 | (if (call f x) 115 | (cons x y) 116 | y)) 117 | 118 | (def consif (x y) 119 | "Cons X and Y if X is non-nil. Otherwise return Y." 120 | (conswhen #'idfn x y)) 121 | 122 | (def cars (seq) 123 | "Returns a list of the cars of each list within a given sequence." 124 | (map #'car seq)) 125 | 126 | (def cdrs (seq) 127 | "Returns a list of the cdrs of each list within a given sequence." 128 | (map #'cdr seq)) 129 | 130 | (def linearlize (arr) 131 | "Return a vector that has the same elements as a possibly 132 | multidimensional array." 133 | (make-array (array-total-size arr) :displaced-to arr)) 134 | 135 | (defgeneric get (obj arg) 136 | (:documentation "Returns whatever is associated with ARG in OBJ.")) 137 | 138 | (defgeneric (setf get) (val obj arg) 139 | (:documentation "Sets ARG to be associated with VAL in OBJ.")) 140 | 141 | (defmethod get ((seq sequence) (n integer)) 142 | "Returns the Nth element of a sequence." 143 | (elt seq n)) 144 | 145 | (defmethod (setf get) (val (seq sequence) (n integer)) 146 | "Sets the Nth element of SEQ to VAL." 147 | (= (elt seq n) val)) 148 | 149 | (defmethod get ((tab hash-table) x) 150 | "Returns whatever is stored in TAB under X." 151 | (gethash x tab)) 152 | 153 | (defmethod (setf get) (val (tab hash-table) x) 154 | "Sets VAL to be stored under X in TAB." 155 | (= (gethash x tab) val)) 156 | 157 | (defmethod get ((a array) (index integer)) 158 | "If A is a vector, return the corresponding element. Otherwise 159 | return a displaced array that acts like the subarray." 160 | (if (vectorp a) 161 | (call-next-method) 162 | (withs ((rows . rest) (array-dimensions a) 163 | size (reduce #'* rest)) 164 | (assert (< index rows) (index) 165 | "Index ~A out of bounds for array with dimension size ~A" index rows) 166 | (make-array rest 167 | :displaced-to a 168 | :displaced-index-offset (* index size))))) 169 | 170 | (defmethod get ((arr array) (list list)) 171 | "It is convient to consider indexing a list into an arraying being 172 | the same as just considering each element of the list as a different 173 | dimension." 174 | (apply #'aref arr list)) 175 | 176 | (defmethod (setf get) (val (arr array) (list list)) 177 | "Sets the value when using an list to access into a array." 178 | (= (apply #'aref arr list) val)) 179 | 180 | (defmethod get (obj x) 181 | "Calls X on OBJECT." 182 | (call x obj)) 183 | 184 | (defmethod (setf get) (val obj x) 185 | "Calls (setf X) on val and obj. This may or may not work depending 186 | on how the setter for X was defined." 187 | (call (fdefinition `(setf ,x)) val obj)) 188 | 189 | (mac trav (x &rest fs) 190 | "Traverse X, calling FS in sequence. The symbol 'recur' is bound to 191 | a procedure which can be used to recursively traverse the object. 192 | The return value is nil." 193 | (w/uniq g 194 | `(rec (,g ,x) 195 | (when ,g 196 | ,@(map (fn (f) `(call ,f ,g)) fs))))) 197 | 198 | (def intersperse (x ys) 199 | "Returns a list with the element X in between every element in YS." 200 | (and ys 201 | (cons (car ys) 202 | (loop for y in (cdr ys) 203 | collect x 204 | collect y)))) 205 | -------------------------------------------------------------------------------- /tests/hof-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :clamp-tests) 2 | (use-syntax :clamp) 3 | 4 | (defsuite hof (clamp)) 5 | 6 | (deftest testify (hof) 7 | (assert-true (call (testify 5) 5)) 8 | (assert-false (call (testify 5) 4)) 9 | (assert-true (call (testify #'even) 4)) 10 | (assert-false (call (testify #'even) 5))) 11 | 12 | (deftest rem (hof) 13 | (assert-equal '() (rem 5 '())) 14 | (assert-equal '() (rem #'even '())) 15 | (assert-equal '(1 2 8 2) (rem 5 '(1 5 2 8 2 5))) 16 | (assert-equal '(5 29 5) (rem #'even '(2 5 29 5 28))) 17 | (assert-equal '() (rem #'even '(2 12 16 4))) 18 | (assert-equal '(13 5 7) (rem #'even '(13 5 7))) 19 | (assert-equal '(3 6 12) (rem 20 '(3 25 6 30 12) :test #'<)) 20 | (assert-equal '(1 2 3 5) (rem #'even '(1 2 3 4 5) :start 3)) 21 | (assert-equal '(35 3 40 6 12) (rem 20 '(35 3 40 25 6 30 12) 22 | :start 3 :test #'<)) 23 | ;; Same tests but with vectors instead. 24 | (assert-equalp #() (rem 5 #())) 25 | (assert-equalp #() (rem #'even #())) 26 | (assert-equalp #(1 2 8 2) (rem 5 #(1 5 2 8 2 5))) 27 | (assert-equalp #(5 29 5) (rem #'even #(2 5 29 5 28))) 28 | (assert-equalp #() (rem #'even #(2 12 16 4))) 29 | (assert-equalp #(13 5 7) (rem #'even #(13 5 7))) 30 | (assert-equalp #(3 6 12) (rem 20 #(3 25 6 30 12) :test #'<)) 31 | (assert-equalp #(1 2 3 5) (rem #'even #(1 2 3 4 5) :start 3)) 32 | (assert-equalp #(35 3 40 6 12) (rem 20 #(35 3 40 25 6 30 12) 33 | :start 3 :test #'<))) 34 | 35 | (deftest keep (hof) 36 | (assert-equal '() (keep 7 '())) 37 | (assert-equal '() (keep #'even '())) 38 | (assert-equal '(2 8 2 4) (keep #'even '(1 2 8 2 3 4))) 39 | (assert-equal '() (keep #'even '(5 7 3))) 40 | (assert-equal '(2 12 72 6) (keep #'even '(2 12 72 6))) 41 | (assert-equal '(25 30) (keep 20 '(3 25 6 30 12) :test #'<)) 42 | (assert-equal '(1 2 3 8 2 4) (keep #'even '(1 2 3 8 5 2 4 1) :start 3)) 43 | (assert-equal '(1 25 3 8 2 4) (keep 9 '(1 25 3 30 25 8 2 15 4) 44 | :test #'> :start 3)) 45 | ;; Same tests but for vectors. 46 | (assert-equalp #() (keep 7 #())) 47 | (assert-equalp #() (keep #'even #())) 48 | (assert-equalp #(2 8 2 4) (keep #'even #(1 2 8 2 3 4))) 49 | (assert-equalp #() (keep #'even #(5 7 3))) 50 | (assert-equalp #(2 12 72 6) (keep #'even #(2 12 72 6))) 51 | (assert-equalp #(25 30) (keep 20 #(3 25 6 30 12) :test #'<)) 52 | (assert-equalp #(1 2 3 8 2 4) (keep #'even #(1 2 3 8 5 2 4 1) :start 3)) 53 | (assert-equalp #(1 25 3 8 2 4) (keep 9 #(1 25 3 30 25 8 2 15 4) 54 | :test #'> :start 3))) 55 | 56 | ;;; Member does not work on vectors (what is the tail of a vector?). 57 | (deftest mem (hof) 58 | (assert-false (mem 7 '())) 59 | (assert-false (mem #'even '())) 60 | (assert-false (mem 3 '(1 29 32 5))) 61 | (assert-equal '(5 3 2) (mem 5 '(1 6 3 5 3 2))) 62 | (assert-equal '(2 3) (mem #'even '(1 9 2 3))) 63 | (assert-equal '(5 6) (mem 4 '(1 2 3 4 5 6) :test #'<))) 64 | 65 | (deftest find (hof) 66 | (assert-false (find 5 '())) 67 | (assert-false (find #'even '())) 68 | (assert-false (find 5 '(2 9 1 2 7 3))) 69 | (assert-eql 5 (find 5 '(1 3 5 2 9 3))) 70 | (assert-eql 2 (find #'even '(1 3 5 2 9 3 4 6 7))) 71 | (assert-eql 5 (find 4 '(1 2 3 4 5 6) :test #'<)) 72 | (assert-eql 4 (find #'even '(1 2 3 4 5 6) :start 3)) 73 | (assert-eql 4 (find 5 '(1 2 3 4 5 6) :test #'/= :start 3)) 74 | ;; Same tests but for vectors. 75 | (assert-false (find 5 #())) 76 | (assert-false (find #'even #())) 77 | (assert-false (find 5 #(2 9 1 2 7 3))) 78 | (assert-eql 5 (find 5 #(1 3 5 2 9 3))) 79 | (assert-eql 2 (find #'even #(1 3 5 2 9 3 4 6 7))) 80 | (assert-eql 5 (find 4 #(1 2 3 4 5 6) :test #'<)) 81 | (assert-eql 4 (find #'even #(1 2 3 4 5 6) :start 3)) 82 | (assert-eql 4 (find 5 #(1 2 3 4 5 6) :test #'/= :start 3))) 83 | 84 | (deftest count (hof) 85 | (assert-eql 0 (count 2 '())) 86 | (assert-eql 0 (count #'even '())) 87 | (assert-eql 0 (count #'even '(1 3 71 21))) 88 | (assert-eql 3 (count 5 '(1 5 3 2 5 7 5))) 89 | (assert-eql 4 (count #'even '(1 6 3 2 2 4))) 90 | (assert-eql 3 (count 3 '(1 2 5 3 2 4) :test #'>)) 91 | (assert-eql 2 (count #'even '(1 2 3 4 5 6 7 8) :start 5)) 92 | (assert-eql 4 (count 5 '(10 11 12 1 2 3 4 5 6 7 8) :test #'<= :start 3)) 93 | ;; Same tests but for vectors. 94 | (assert-eql 0 (count 2 #())) 95 | (assert-eql 0 (count #'even #())) 96 | (assert-eql 0 (count #'even #(1 3 71 21))) 97 | (assert-eql 3 (count 5 #(1 5 3 2 5 7 5))) 98 | (assert-eql 4 (count #'even #(1 6 3 2 2 4))) 99 | (assert-eql 3 (count 3 #(1 2 5 3 2 4) :test #'>)) 100 | (assert-eql 2 (count #'even #(1 2 3 4 5 6 7 8) :start 5)) 101 | (assert-eql 4 (count 5 #(10 11 12 1 2 3 4 5 6 7 8) :test #'<= :start 3))) 102 | 103 | (deftest pos (hof) 104 | (assert-false (pos 2 '())) 105 | (assert-false (pos #'even '())) 106 | (assert-false (pos #'even '(123 45 3 7))) 107 | (assert-eql 2 (pos 5 '(1 3 5 3 2 5))) 108 | (assert-eql 3 (pos #'even '(1 7 3 2 5 7 4 2))) 109 | (assert-eql 4 (pos 4 '(1 2 3 4 5 6) :test #'<)) 110 | (assert-eql 4 (pos 3 '(1 2 3 4 3 2 1) :start 3)) 111 | (assert-eql 5 (pos 7 '(1 2 10 11 12 1 2 3) :start 2 :test #'>)) 112 | ;; Same tests but for vectors. 113 | (assert-false (pos 2 #())) 114 | (assert-false (pos #'even #())) 115 | (assert-false (pos #'even #(123 45 3 7))) 116 | (assert-eql 2 (pos 5 #(1 3 5 3 2 5))) 117 | (assert-eql 3 (pos #'even #(1 7 3 2 5 7 4 2))) 118 | (assert-eql 4 (pos 4 #(1 2 3 4 5 6) :test #'<)) 119 | (assert-eql 4 (pos 3 #(1 2 3 4 3 2 1) :start 3)) 120 | (assert-eql 5 (pos 7 #(1 2 10 11 12 1 2 3) :start 2 :test #'>))) 121 | 122 | (deftest mappend (hof) 123 | (assert-equal '() (mappend #'identity '())) 124 | (assert-equal '(1 4 2 5 3 6) (mappend #'list '(1 2 3) '(4 5 6)))) 125 | 126 | (deftest partition (hof) 127 | (assert-equal '(() ()) (mvl (partition #'even '()))) 128 | (assert-equal '(() ()) (mvl (partition 1 '()))) 129 | (assert-equal '((2 4) (1 3 5)) (mvl (partition #'even '(1 2 3 4 5)))) 130 | (assert-equal '((4) (5)) (mvl (partition #'even '(1 2 3 4 5) :start 3))) 131 | (assert-equal '((1 1 1) (0)) (mvl (partition 1 '(1 0 1 1)))) 132 | (assert-equal '(((2) (4)) ((1) (3) (5))) 133 | (mvl (partition #'even '((1) (2) (3) (4) (5)) :key #'car))) 134 | (assert-equal '(((4)) ((5))) 135 | (mvl (partition #'even '((1) (2) (3) (4) (5)) 136 | :key #'car 137 | :start 3))) 138 | ;; Same tests but for vectors. 139 | (assert-equal '(() ()) (mvl (partition #'even #()))) 140 | (assert-equal '(() ()) (mvl (partition 1 #()))) 141 | (assert-equal '((2 4) (1 3 5)) (mvl (partition #'even #(1 2 3 4 5)))) 142 | (assert-equal '((4) (5)) (mvl (partition #'even #(1 2 3 4 5) :start 3))) 143 | (assert-equal '((1 1 1) (0)) (mvl (partition 1 #(1 0 1 1)))) 144 | (assert-equal '(((2) (4)) ((1) (3) (5))) 145 | (mvl (partition #'even #((1) (2) (3) (4) (5)) :key #'car))) 146 | (assert-equal '(((4)) ((5))) 147 | (mvl (partition #'even #((1) (2) (3) (4) (5)) 148 | :key #'car 149 | :start 3)))) 150 | 151 | (deftest trues (hof) 152 | (let alist '((a 1) (b 2) (c 3)) 153 | (assert-equal '((c 3) (a 1)) 154 | (trues [assoc _ alist] 155 | '(c d a))))) 156 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Artistic License 2.0 2 | 3 | Copyright (c) 2014 malisper 4 | 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | This license establishes the terms under which a given free software 11 | Package may be copied, modified, distributed, and/or redistributed. 12 | The intent is that the Copyright Holder maintains some artistic 13 | control over the development of that Package while still keeping the 14 | Package available as open source and free software. 15 | 16 | You are always permitted to make arrangements wholly outside of this 17 | license directly with the Copyright Holder of a given Package. If the 18 | terms of this license do not permit the full use that you propose to 19 | make of the Package, you should contact the Copyright Holder and seek 20 | a different licensing arrangement. 21 | 22 | Definitions 23 | 24 | "Copyright Holder" means the individual(s) or organization(s) 25 | named in the copyright notice for the entire Package. 26 | 27 | "Contributor" means any party that has contributed code or other 28 | material to the Package, in accordance with the Copyright Holder's 29 | procedures. 30 | 31 | "You" and "your" means any person who would like to copy, 32 | distribute, or modify the Package. 33 | 34 | "Package" means the collection of files distributed by the 35 | Copyright Holder, and derivatives of that collection and/or of 36 | those files. A given Package may consist of either the Standard 37 | Version, or a Modified Version. 38 | 39 | "Distribute" means providing a copy of the Package or making it 40 | accessible to anyone else, or in the case of a company or 41 | organization, to others outside of your company or organization. 42 | 43 | "Distributor Fee" means any fee that you charge for Distributing 44 | this Package or providing support for this Package to another 45 | party. It does not mean licensing fees. 46 | 47 | "Standard Version" refers to the Package if it has not been 48 | modified, or has been modified only in ways explicitly requested 49 | by the Copyright Holder. 50 | 51 | "Modified Version" means the Package, if it has been changed, and 52 | such changes were not explicitly requested by the Copyright 53 | Holder. 54 | 55 | "Original License" means this Artistic License as Distributed with 56 | the Standard Version of the Package, in its current version or as 57 | it may be modified by The Perl Foundation in the future. 58 | 59 | "Source" form means the source code, documentation source, and 60 | configuration files for the Package. 61 | 62 | "Compiled" form means the compiled bytecode, object code, binary, 63 | or any other form resulting from mechanical transformation or 64 | translation of the Source form. 65 | 66 | 67 | Permission for Use and Modification Without Distribution 68 | 69 | (1) You are permitted to use the Standard Version and create and use 70 | Modified Versions for any purpose without restriction, provided that 71 | you do not Distribute the Modified Version. 72 | 73 | 74 | Permissions for Redistribution of the Standard Version 75 | 76 | (2) You may Distribute verbatim copies of the Source form of the 77 | Standard Version of this Package in any medium without restriction, 78 | either gratis or for a Distributor Fee, provided that you duplicate 79 | all of the original copyright notices and associated disclaimers. At 80 | your discretion, such verbatim copies may or may not include a 81 | Compiled form of the Package. 82 | 83 | (3) You may apply any bug fixes, portability changes, and other 84 | modifications made available from the Copyright Holder. The resulting 85 | Package will still be considered the Standard Version, and as such 86 | will be subject to the Original License. 87 | 88 | 89 | Distribution of Modified Versions of the Package as Source 90 | 91 | (4) You may Distribute your Modified Version as Source (either gratis 92 | or for a Distributor Fee, and with or without a Compiled form of the 93 | Modified Version) provided that you clearly document how it differs 94 | from the Standard Version, including, but not limited to, documenting 95 | any non-standard features, executables, or modules, and provided that 96 | you do at least ONE of the following: 97 | 98 | (a) make the Modified Version available to the Copyright Holder 99 | of the Standard Version, under the Original License, so that the 100 | Copyright Holder may include your modifications in the Standard 101 | Version. 102 | 103 | (b) ensure that installation of your Modified Version does not 104 | prevent the user installing or running the Standard Version. In 105 | addition, the Modified Version must bear a name that is different 106 | from the name of the Standard Version. 107 | 108 | (c) allow anyone who receives a copy of the Modified Version to 109 | make the Source form of the Modified Version available to others 110 | under 111 | 112 | (i) the Original License or 113 | 114 | (ii) a license that permits the licensee to freely copy, 115 | modify and redistribute the Modified Version using the same 116 | licensing terms that apply to the copy that the licensee 117 | received, and requires that the Source form of the Modified 118 | Version, and of any works derived from it, be made freely 119 | available in that license fees are prohibited but Distributor 120 | Fees are allowed. 121 | 122 | 123 | Distribution of Compiled Forms of the Standard Version 124 | or Modified Versions without the Source 125 | 126 | (5) You may Distribute Compiled forms of the Standard Version without 127 | the Source, provided that you include complete instructions on how to 128 | get the Source of the Standard Version. Such instructions must be 129 | valid at the time of your distribution. If these instructions, at any 130 | time while you are carrying out such distribution, become invalid, you 131 | must provide new instructions on demand or cease further distribution. 132 | If you provide valid instructions or cease distribution within thirty 133 | days after you become aware that the instructions are invalid, then 134 | you do not forfeit any of your rights under this license. 135 | 136 | (6) You may Distribute a Modified Version in Compiled form without 137 | the Source, provided that you comply with Section 4 with respect to 138 | the Source of the Modified Version. 139 | 140 | 141 | Aggregating or Linking the Package 142 | 143 | (7) You may aggregate the Package (either the Standard Version or 144 | Modified Version) with other packages and Distribute the resulting 145 | aggregation provided that you do not charge a licensing fee for the 146 | Package. Distributor Fees are permitted, and licensing fees for other 147 | components in the aggregation are permitted. The terms of this license 148 | apply to the use and Distribution of the Standard or Modified Versions 149 | as included in the aggregation. 150 | 151 | (8) You are permitted to link Modified and Standard Versions with 152 | other works, to embed the Package in a larger work of your own, or to 153 | build stand-alone binary or bytecode versions of applications that 154 | include the Package, and Distribute the result without restriction, 155 | provided the result does not expose a direct interface to the Package. 156 | 157 | 158 | Items That are Not Considered Part of a Modified Version 159 | 160 | (9) Works (including, but not limited to, modules and scripts) that 161 | merely extend or make use of the Package, do not, by themselves, cause 162 | the Package to be a Modified Version. In addition, such works are not 163 | considered parts of the Package itself, and are not subject to the 164 | terms of this license. 165 | 166 | 167 | General Provisions 168 | 169 | (10) Any use, modification, and distribution of the Standard or 170 | Modified Versions is governed by this Artistic License. By using, 171 | modifying or distributing the Package, you accept this license. Do not 172 | use, modify, or distribute the Package, if you do not accept this 173 | license. 174 | 175 | (11) If your Modified Version has been derived from a Modified 176 | Version made by someone other than you, you are nevertheless required 177 | to ensure that your Modified Version complies with the requirements of 178 | this license. 179 | 180 | (12) This license does not grant you the right to use any trademark, 181 | service mark, tradename, or logo of the Copyright Holder. 182 | 183 | (13) This license includes the non-exclusive, worldwide, 184 | free-of-charge patent license to make, have made, use, offer to sell, 185 | sell, import and otherwise transfer the Package with respect to any 186 | patent claims licensable by the Copyright Holder that are necessarily 187 | infringed by the Package. If you institute patent litigation 188 | (including a cross-claim or counterclaim) against any party alleging 189 | that the Package constitutes direct or contributory patent 190 | infringement, then this Artistic License to you shall terminate on the 191 | date that such litigation is filed. 192 | 193 | (14) Disclaimer of Warranty: 194 | THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS 195 | IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED 196 | WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR 197 | NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL 198 | LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL 199 | BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 200 | DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF 201 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; This is the package declaration for clamp. 2 | 3 | (defpackage :clamp 4 | (:nicknames :clamp) 5 | (:use :common-lisp :iterate) 6 | (:shadow :do :map :if :case := :ccase :ecase :typecase :rem :let 7 | :find :count :sort :++ :read :read-line :get :set 8 | :last :summing :with :repeat :while :until :in :string) 9 | (:import-from :syntax :define-package-syntax :use-syntax) 10 | (:export 11 | ;; From defalias. 12 | :defalias 13 | ;; From aliases 14 | :def :mac :++ :-- :mvb :mvl :do :do1 :do2 := :is :iso :no :len 15 | :map :isa :uniq :even :odd :redup :dedup :table :rand :trunc :join 16 | :cut :rev :nrev :const :idfn :outstring :inside :instring :errsafe 17 | :w/file :swap :writec :notf :macex :macex1 :letter :alphadig 18 | :upcase :all :maptable :inc :dec :call :probe-file :bound :digit 19 | :err :lastcons :doc :seconds :inst :readstring1 :negative :positive 20 | :after 21 | 22 | ;; From base. 23 | :_ :single :if :fn 24 | 25 | ;; From binding. 26 | :with :let :ret :rets :rets1 :flet1 :withs 27 | 28 | ;; From print. 29 | :pr :prn :prf :prs :prns :w/outstring :tostring :w/instring :fromstring 30 | :tofile :fromfile :sp :bar* :w/bars 31 | 32 | ;; From time. 33 | :since :minutes-since :hours-since :days-since :jtime :time10 34 | :date :datestring 35 | 36 | ;; From hof. 37 | :mapv :testify :rem :keep :mem :find :count :pos :mappend 38 | :partition :trues :mapeach :mappendeach :positions :hofeach 39 | 40 | ;; From conditionals. 41 | :iflet :whenlet :aif :it :awhen :aand :aif2 :iflet2 :aand2 :case 42 | :ccase :ecase :caselet :typecase :switchlet :switch :or2 43 | 44 | ;; From list. 45 | :mklist :dotted :proper :range :firstn :last :flat :len< :len> 46 | :n-of :drain :split :group :caris :carif :consif :conswhen :cars 47 | :cdrs :get :trav :intersperse :linearlize :pull 48 | 49 | ;; From macros. 50 | :w/uniq :mkstr :symb :check-len :once-only 51 | 52 | ;; From iter. 53 | :repeat :upto :up :downfrom :down :while :until :each :on :index 54 | :whilet :whiler :forlen :iter 55 | 56 | ;; From fns. 57 | :rec :recur :rfn :afn :self 58 | 59 | ;; From misc. 60 | :ado :accum :summing :multiple :check :acheck :in :cart :rand-elt 61 | :rand-choice :point :defs :roundup :nearest :before :calln 62 | 63 | ;; From setforms. 64 | :setforms :zap :or= :or2= :set :wipe 65 | 66 | ;; From fnops. 67 | :compose :fif :andf :orf :curry :rcurry :flip 68 | 69 | ;; From sort. 70 | :compare :best :bestn :sort :nsort :ssort :nssort :med 71 | 72 | ;; From memoize. 73 | :memo :defmemo 74 | 75 | ;; From tables. 76 | :keys :vals :listtab :tablist :obj :alref :counts :commonest 77 | :memtable 78 | 79 | ;; From io. 80 | :w/infile :w/outfile :w/appendfile :allchars :filechars :readfile 81 | :readfile1 :writefile 82 | 83 | ;; From strings. 84 | :newstring :whitec :nonwhite :nonwhite :punc :tokens :upcase 85 | :downcase :headmatch :begins :ellipsize 86 | 87 | ;; From read. 88 | :readb :readc :peekc :read :read-line :readall 89 | 90 | ;; From disk. 91 | :savers* :fromdisk :diskvar :todisk 92 | 93 | ;; From code. 94 | :codelines :codeflat :tokcount 95 | 96 | ;; From deftem. 97 | :deftem 98 | 99 | ;; Symbols to be exported from the common-lisp package. This 100 | ;; makes it easy to import clamp (which shadows some names) and 101 | ;; still access everything from common-lisp. Some symbols whose 102 | ;; use is discouraged (such as rplaca) are also removed. Symbols 103 | ;; which would normally be commented out on the beginning of the 104 | ;; are moved to the end of the previous because otherwise it 105 | ;; leads to weird indentation. 106 | :&allow-other-keys :&aux :&body :&environment :&key :&optional :&rest 107 | :&whole :* :** :*** :*break-on-signals* :*compile-file-pathname* 108 | :*compile-file-truename* :*compile-print* :*compile-verbose* :*debug-io* 109 | :*debugger-hook* :*default-pathname-defaults* :*error-output* :*features* 110 | :*gensym-counter* :*load-pathname* :*load-print* :*load-truename* 111 | :*load-verbose* :*macroexpand-hook* :*modules* :*package* :*print-array* 112 | :*print-base* :*print-case* :*print-circle* :*print-escape* 113 | :*print-gensym* :*print-length* :*print-level* :*print-lines* 114 | :*print-miser-width* :*print-pprint-dispatch* :*print-pretty* 115 | :*print-radix* :*print-readably* :*print-right-margin* :*query-io* 116 | :*random-state* :*read-base* :*read-default-float-format* :*read-eval* 117 | :*read-suppress* :*readtable* :*standard-input* :*standard-output* 118 | :*terminal-io* :*trace-output* :+ #|:++|# :+++ :- :/ :// :/// :/= :1+ 119 | :1- :< :<= := :> :>= :abort :abs :acons :acos :acosh :add-method 120 | :adjoin :adjust-array :adjustable-array-p :allocate-instance 121 | :alpha-char-p :alphanumericp :and :append :apply :apropos :apropos-list 122 | :aref :arithmetic-error :arithmetic-error-operands 123 | :arithmetic-error-operation :array :array-dimension :array-dimension-limit 124 | :array-dimensions :array-displacement :array-element-type 125 | :array-has-fill-pointer-p :array-in-bounds-p :array-rank :array-rank-limit 126 | :array-row-major-index :array-total-size :array-total-size-limit :arrayp 127 | :ash :asin :asinh :assert :assoc :assoc-if :assoc-if-not :atan :atanh 128 | :atom :base-char :base-string :bignum :bit :bit-and :bit-andc1 129 | :bit-andc2 :bit-eqv :bit-ior :bit-nand :bit-nor :bit-not :bit-orc1 130 | :bit-orc2 :bit-vector :bit-vector-p :bit-xor :block :boole :boole-1 131 | :boole-2 :boole-and :boole-andc1 :boole-andc2 :boole-c1 :boole-c2 132 | :boole-clr :boole-eqv :boole-ior :boole-nand :boole-nor :boole-orc1 133 | :boole-orc2 :boole-set :boole-xor :boolean :both-case-p :boundp :break 134 | :broadcast-stream :broadcast-stream-streams :built-in-class :butlast 135 | :byte :byte-position :byte-size :caaaar :caaadr :caaar :caadar :caaddr 136 | :caadr :caar :cadaar :cadadr :cadar :caddar :cadddr :caddr :cadr #|:ccase|# 137 | :call-arguments-limit :call-method :call-next-method :car #|:case|# :catch 138 | :cdaaar :cdaadr :cdaar :cdadar :cdaddr :cdadr :cdar :cddaar 139 | :cddadr :cddar :cdddar :cddddr :cdddr :cddr :cdr :ceiling :cell-error 140 | :cell-error-name :cerror :change-class :char :char-code :char-code-limit 141 | :char-downcase :char-equal :char-greaterp :char-int :char-lessp 142 | :char-name :char-not-equal :char-not-greaterp :char-not-lessp 143 | :char-upcase :char/= :char< :char<= :char= :char> :char>= :character 144 | :characterp :check-type :cis :class :class-name :class-of :clear-input 145 | :clear-output :close :clrhash :code-char :coerce :compilation-speed 146 | :compile :compile-file :compile-file-pathname :compiled-function 147 | :compiled-function-p :compiler-macro :compiler-macro-function :complement 148 | :complex :complexp :compute-applicable-methods :compute-restarts 149 | :concatenate :concatenated-stream :concatenated-stream-streams :cond 150 | :condition :conjugate :cons :consp :constantly :constantp :continue 151 | :control-error :copy-alist :copy-list :copy-pprint-dispatch 152 | :copy-readtable :copy-seq :copy-structure :copy-symbol :copy-tree :cos 153 | :cosh #|:count|# :count-if :count-if-not :ctypecase :debug :decf :declaim 154 | :declaration :declare :decode-float :decode-universal-time :defclass 155 | :defconstant :defgeneric :define-compiler-macro :define-condition 156 | :define-method-combination :define-modify-macro :define-setf-expander 157 | :define-symbol-macro :defmacro :defmethod :defpackage :defparameter 158 | :defsetf :defstruct :deftype :defun :defvar :delete :delete-duplicates 159 | :delete-file :delete-if :delete-if-not :delete-package :denominator 160 | :deposit-field :describe :describe-object :destructuring-bind :digit-char 161 | :digit-char-p :directory :directory-namestring :disassemble 162 | :division-by-zero #|:do|# :do* :do-all-symbols :do-external-symbols 163 | :do-symbols :documentation :dolist :dotimes :double-float 164 | :double-float-epsilon :double-float-negative-epsilon :dpb :dribble 165 | :dynamic-extent #|:ecase|# :echo-stream :echo-stream-input-stream 166 | :echo-stream-output-stream :ed :eighth :elt :encode-universal-time 167 | :end-of-file :endp :enough-namestring :ensure-directories-exist 168 | :ensure-generic-function :eq :eql :equal :equalp :error :etypecase 169 | :eval :eval-when :evenp :every :exp :export :expt :extended-char 170 | :fboundp :fceiling :fdefinition :ffloor :fifth :file-author :file-error 171 | :file-error-pathname :file-length :file-namestring :file-position 172 | :file-stream :file-string-length :file-write-date :fill :fill-pointer #|:find|# 173 | :find-all-symbols :find-class :find-if :find-if-not :find-method 174 | :find-package :find-restart :find-symbol :finish-output :first :fixnum 175 | :flet :float :float-digits :float-precision :float-radix :float-sign 176 | :floating-point-inexact :floating-point-invalid-operation 177 | :floating-point-overflow :floating-point-underflow :floatp :floor 178 | :fmakunbound :force-output :format :formatter :fourth :fresh-line 179 | :fround :ftruncate :ftype :funcall :function :function-keywords 180 | :function-lambda-expression :functionp :gcd :generic-function :gensym 181 | :gentemp #|:get|# :get-decoded-time :get-dispatch-macro-character 182 | :get-internal-real-time :get-internal-run-time :get-macro-character 183 | :get-output-stream-string :get-properties :get-setf-expansion 184 | :get-universal-time :getf :gethash :go :graphic-char-p :handler-bind 185 | :handler-case :hash-table :hash-table-count :hash-table-p 186 | :hash-table-rehash-size :hash-table-rehash-threshold :hash-table-size 187 | :hash-table-test :host-namestring :identity #|:if|# :ignorable :ignore 188 | :ignore-errors :imagpart :import :in-package :incf :initialize-instance 189 | :inline :input-stream-p :inspect :integer :integer-decode-float 190 | :integer-length :integerp :interactive-stream-p :intern 191 | :internal-time-units-per-second :intersection :invalid-method-error 192 | :invoke-debugger :invoke-restart :invoke-restart-interactively :isqrt 193 | :keyword :keywordp :labels :lambda :lambda-list-keywords 194 | :lambda-parameters-limit :lcm :ldb :ldb-test :ldiff 195 | :least-negative-double-float :least-negative-long-float 196 | :least-negative-normalized-double-float 197 | :least-negative-normalized-long-float :least-negative-normalized-short-float 198 | :least-negative-normalized-single-float :least-negative-short-float 199 | :least-negative-single-float :least-positive-double-float 200 | :least-positive-long-float :least-positive-normalized-double-float 201 | :least-positive-normalized-long-float :least-positive-normalized-short-float 202 | :least-positive-normalized-single-float :least-positive-short-float 203 | :least-positive-single-float :length #|:let|# :let* :lisp-implementation-type 204 | :lisp-implementation-version :list :list* :list-all-packages :list-length 205 | :listen :listp :load :load-logical-pathname-translations :load-time-value 206 | :locally :log :logand :logandc1 :logandc2 :logbitp :logcount :logeqv 207 | :logical-pathname :logical-pathname-translations :logior :lognand :lognor 208 | :lognot :logorc1 :logorc2 :logtest :logxor :long-float 209 | :long-float-epsilon :long-float-negative-epsilon :long-site-name :loop 210 | :loop-finish :lower-case-p :machine-instance :machine-type 211 | :machine-version :macro-function :macroexpand :macroexpand-1 :macrolet 212 | :make-array :make-broadcast-stream :make-concatenated-stream 213 | :make-condition :make-dispatch-macro-character :make-echo-stream 214 | :make-hash-table :make-instance :make-instances-obsolete :make-list 215 | :make-load-form :make-load-form-saving-slots :make-method :make-package 216 | :make-pathname :make-random-state :make-sequence :make-string 217 | :make-string-input-stream :make-string-output-stream :make-symbol 218 | :make-synonym-stream :make-two-way-stream :makunbound #|:map|# :map-into 219 | :mapc :mapcan :mapcar :mapcon :maphash :mapl :maplist :mask-field 220 | :max :member :member-if :member-if-not :merge :merge-pathnames :method 221 | :method-combination :method-combination-error :method-qualifiers :min 222 | :minusp :mismatch :mod :most-negative-double-float :most-negative-fixnum 223 | :most-negative-long-float :most-negative-short-float 224 | :most-negative-single-float :most-positive-double-float 225 | :most-positive-fixnum :most-positive-long-float :most-positive-short-float 226 | :most-positive-single-float :muffle-warning :multiple-value-bind 227 | :multiple-value-call :multiple-value-list :multiple-value-prog1 228 | :multiple-value-setq :multiple-values-limit :name-char :namestring 229 | :nbutlast :nconc :next-method-p :nil :nintersection :ninth 230 | :no-applicable-method :no-next-method :not :notany :notevery :notinline 231 | :nreconc :nreverse :nset-difference :nset-exclusive-or 232 | :nstring-capitalize :nstring-downcase :nstring-upcase :nsublis :nsubst 233 | :nsubst-if :nsubst-if-not :nsubstitute :nsubstitute-if 234 | :nsubstitute-if-not :nth :nth-value :nthcdr :null :number :numberp 235 | :numerator :nunion :oddp :open :open-stream-p :optimize :or :otherwise 236 | :output-stream-p :package :package-error :package-error-package 237 | :package-name :package-nicknames :package-shadowing-symbols 238 | :package-use-list :package-used-by-list :packagep :pairlis :parse-error 239 | :parse-integer :parse-namestring :pathname :pathname-device 240 | :pathname-directory :pathname-host :pathname-match-p :pathname-name 241 | :pathname-type :pathname-version :pathnamep :peek-char :phase :pi 242 | :plusp :pop :position :position-if :position-if-not :pprint 243 | :pprint-dispatch :pprint-exit-if-list-exhausted :pprint-fill 244 | :pprint-indent :pprint-linear :pprint-logical-block :pprint-newline 245 | :pprint-pop :pprint-tab :pprint-tabular :prin1 :prin1-to-string :princ 246 | :princ-to-string :print :print-not-readable :print-not-readable-object 247 | :print-object :print-unreadable-object :probe-file :proclaim :prog 248 | :prog* :prog1 :prog2 :progn :program-error :progv :provide :psetf 249 | :psetq :push :pushnew :quote :random :random-state :random-state-p 250 | :rassoc :rassoc-if :rassoc-if-not :ratio :rational :rationalize 251 | :rationalp #|:read|# :read-byte :read-char :read-char-no-hang 252 | :read-delimited-list :read-from-string #|:read-line|# 253 | :read-preserving-whitespace :read-sequence :reader-error :readtable 254 | :readtable-case :readtablep :real :realp :realpart :reduce 255 | :reinitialize-instance #|:rem|# :remf :remhash :remove :remove-duplicates 256 | :remove-if :remove-if-not :remove-method :remprop :rename-file 257 | :rename-package :replace :require :rest :restart :restart-bind 258 | :restart-case :restart-name :return :return-from :revappend :reverse 259 | :room :rotatef :round :row-major-aref #|:rplaca|# #|:rplacd|# :safety 260 | :satisfies :sbit :scale-float :schar :search :second :sequence 261 | :serious-condition #|:set|# :set-difference :set-dispatch-macro-character 262 | :set-exclusive-or :set-macro-character :set-pprint-dispatch 263 | :set-syntax-from-char :setf #|:setq|# :seventh :shadow :shadowing-import 264 | :shared-initialize :shiftf :short-float :short-float-epsilon 265 | :short-float-negative-epsilon :short-site-name :signal :signed-byte 266 | :signum :simple-array :simple-base-string :simple-bit-vector 267 | :simple-bit-vector-p :simple-condition :simple-condition-format-arguments 268 | :simple-condition-format-control :simple-error :simple-string 269 | :simple-string-p :simple-type-error :simple-vector :simple-vector-p 270 | :simple-warning :sin :single-float :single-float-epsilon 271 | :single-float-negative-epsilon :sinh :sixth :sleep :slot-boundp 272 | :slot-exists-p :slot-makunbound :slot-missing :slot-unbound :slot-value 273 | :software-type :software-version :some #|:sort|# :space :special 274 | :special-operator-p :speed :sqrt :stable-sort :standard :standard-char 275 | :standard-char-p :standard-class :standard-generic-function 276 | :standard-method :standard-object :step :storage-condition :store-value 277 | :stream :stream-element-type :stream-error :stream-error-stream 278 | :stream-external-format :streamp :string :string-capitalize 279 | :string-downcase :string-equal :string-greaterp :string-left-trim 280 | :string-lessp :string-not-equal :string-not-greaterp :string-not-lessp 281 | :string-right-trim :string-stream :string-trim :string-upcase :string/= 282 | :string< :string<= :string= :string> :string>= :stringp :structure 283 | :structure-class :structure-object :style-warning :sublis :subseq 284 | :subsetp :subst :subst-if :subst-if-not :substitute :substitute-if 285 | :substitute-if-not :subtypep :svref :sxhash :symbol :symbol-function 286 | :symbol-macrolet :symbol-name :symbol-package :symbol-plist :symbol-value 287 | :symbolp :synonym-stream :synonym-stream-symbol :t :tagbody :tailp :tan 288 | :tanh :tenth :terpri :the :third :throw :time :trace 289 | :translate-logical-pathname :translate-pathname :tree-equal :truename 290 | :truncate :two-way-stream :two-way-stream-input-stream 291 | :two-way-stream-output-stream :type :type-error :type-error-datum 292 | :type-error-expected-type :type-of :typecase :typep :unbound-slot 293 | :unbound-slot-instance :unbound-variable :undefined-function :unexport 294 | :unintern :union :unless :unread-char :unsigned-byte :untrace 295 | :unuse-package :unwind-protect :update-instance-for-different-class 296 | :update-instance-for-redefined-class :upgraded-array-element-type 297 | :upgraded-complex-part-type :upper-case-p :use-package :use-value 298 | :user-homedir-pathname :values :values-list :variable :vector 299 | :vector-pop :vector-push :vector-push-extend :vectorp :warn :warning 300 | :when :wild-pathname-p :with-accessors :with-compilation-unit 301 | :with-condition-restarts :with-hash-table-iterator :with-input-from-string 302 | :with-open-file :with-open-stream :with-output-to-string 303 | :with-package-iterator :with-simple-restart :with-slots 304 | :with-standard-io-syntax :write :write-byte :write-char :write-line 305 | :write-sequence :write-string :write-to-string :y-or-n-p :yes-or-no-p 306 | :zerop)) 307 | --------------------------------------------------------------------------------