Add Common Lisp syntax highlighting test files

tests/syntax-tests/highlighted/Lisp/utils.lisp

@@ -0,0 +1,80 @@
+(cl:defpackage :chillax.utils
+  (:use :cl :alexandria)
+  (:export
+   :fun :mkhash :hashget :strcat :dequote :at))
+(in-package :chillax.utils)
+
+;;; Functions
+(defmacro fun (&body body)
+  "This macro puts the FUN back in FUNCTION."
+  `(lambda (&optional _) (declare (ignorable _)) ,@body))
+
+;;; Hash tables
+(defun mkhash (&rest keys-and-values &aux (table (make-hash-table :test #'equal)))
+  "Convenience function for `literal' hash table definition."
+  (loop for (key val) on keys-and-values by #'cddr do (setf (gethash key table) val)
+     finally (return table)))
+
+(defun hashget (hash &rest keys)
+  "Convenience function for recursively accessing hash tables."
+  (reduce (lambda (h k) (gethash k h)) keys :initial-value hash))
+
+(define-compiler-macro hashget (hash &rest keys)
+  (if (null keys) hash
+      (let ((hash-sym (make-symbol "HASH"))
+            (key-syms (loop for i below (length keys)
+                         collect (make-symbol (format nil "~:@(~:R~)-KEY" i)))))
+        `(let ((,hash-sym ,hash)
+               ,@(loop for key in keys for sym in key-syms
+                    collect `(,sym ,key)))
+           ,(reduce (lambda (hash key) `(gethash ,key ,hash))
+                    key-syms :initial-value hash-sym)))))
+
+(defun (setf hashget) (new-value hash key &rest more-keys)
+  "Uses the last key given to hashget to insert NEW-VALUE into the hash table
+returned by the second-to-last key.
+tl;dr: DWIM SETF function for HASHGET."
+  (if more-keys
+      (setf (gethash (car (last more-keys))
+                     (apply #'hashget hash key (butlast more-keys)))
+            new-value)
+      (setf (gethash key hash) new-value)))
+
+;;; Strings
+(defun strcat (string &rest more-strings)
+  (apply #'concatenate 'string string more-strings))
+
+(defun dequote (string)
+  (let ((len (length string)))
+    (if (and (> len 1) (starts-with #\" string) (ends-with #\" string))
+      (subseq string 1 (- len 1))
+      string)))
+
+;;;
+;;; At
+;;;
+(defgeneric at (doc &rest keys))
+(defgeneric (setf at) (new-value doc key &rest more-keys))
+
+(defmethod at ((doc hash-table) &rest keys)
+  (apply #'hashget doc keys))
+(defmethod (setf at) (new-value (doc hash-table) key &rest more-keys)
+  (apply #'(setf hashget) new-value doc key more-keys))
+
+(defmethod at ((doc list) &rest keys)
+  (reduce (lambda (alist key)
+            (cdr (assoc key alist :test #'equal)))
+          keys :initial-value doc))
+(defmethod (setf at) (new-value (doc list) key &rest more-keys)
+  (if more-keys
+      (setf (cdr (assoc (car (last more-keys))
+                        (apply #'at doc key (butlast more-keys))
+                        :test #'equal))
+            new-value)
+      (setf (cdr (assoc key doc :test #'equal)) new-value)))
+
+;; A playful alias.
+(defun @ (doc &rest keys)
+  (apply #'at doc keys))
+(defun (setf @) (new-value doc key &rest more-keys)
+  (apply #'(setf at) new-value doc key more-keys))

tests/syntax-tests/source/Lisp/LICENSE.md

@@ -0,0 +1,24 @@
+The `utils.lisp` file has been added from https://github.com/zkat/chillax under the following license: 
+
+Copyright © 2009-2010 Kat Marchán
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the "Software"), to deal in the Software without
+restriction, including without limitation the rights to use, copy,
+modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+DEALINGS IN THE SOFTWARE.
+

tests/syntax-tests/source/Lisp/utils.lisp

@@ -0,0 +1,80 @@
+(cl:defpackage :chillax.utils
+  (:use :cl :alexandria)
+  (:export
+   :fun :mkhash :hashget :strcat :dequote :at))
+(in-package :chillax.utils)
+
+;;; Functions
+(defmacro fun (&body body)
+  "This macro puts the FUN back in FUNCTION."
+  `(lambda (&optional _) (declare (ignorable _)) ,@body))
+
+;;; Hash tables
+(defun mkhash (&rest keys-and-values &aux (table (make-hash-table :test #'equal)))
+  "Convenience function for `literal' hash table definition."
+  (loop for (key val) on keys-and-values by #'cddr do (setf (gethash key table) val)
+     finally (return table)))
+
+(defun hashget (hash &rest keys)
+  "Convenience function for recursively accessing hash tables."
+  (reduce (lambda (h k) (gethash k h)) keys :initial-value hash))
+
+(define-compiler-macro hashget (hash &rest keys)
+  (if (null keys) hash
+      (let ((hash-sym (make-symbol "HASH"))
+            (key-syms (loop for i below (length keys)
+                         collect (make-symbol (format nil "~:@(~:R~)-KEY" i)))))
+        `(let ((,hash-sym ,hash)
+               ,@(loop for key in keys for sym in key-syms
+                    collect `(,sym ,key)))
+           ,(reduce (lambda (hash key) `(gethash ,key ,hash))
+                    key-syms :initial-value hash-sym)))))
+
+(defun (setf hashget) (new-value hash key &rest more-keys)
+  "Uses the last key given to hashget to insert NEW-VALUE into the hash table
+returned by the second-to-last key.
+tl;dr: DWIM SETF function for HASHGET."
+  (if more-keys
+      (setf (gethash (car (last more-keys))
+                     (apply #'hashget hash key (butlast more-keys)))
+            new-value)
+      (setf (gethash key hash) new-value)))
+
+;;; Strings
+(defun strcat (string &rest more-strings)
+  (apply #'concatenate 'string string more-strings))
+
+(defun dequote (string)
+  (let ((len (length string)))
+    (if (and (> len 1) (starts-with #\" string) (ends-with #\" string))
+      (subseq string 1 (- len 1))
+      string)))
+
+;;;
+;;; At
+;;;
+(defgeneric at (doc &rest keys))
+(defgeneric (setf at) (new-value doc key &rest more-keys))
+
+(defmethod at ((doc hash-table) &rest keys)
+  (apply #'hashget doc keys))
+(defmethod (setf at) (new-value (doc hash-table) key &rest more-keys)
+  (apply #'(setf hashget) new-value doc key more-keys))
+
+(defmethod at ((doc list) &rest keys)
+  (reduce (lambda (alist key)
+            (cdr (assoc key alist :test #'equal)))
+          keys :initial-value doc))
+(defmethod (setf at) (new-value (doc list) key &rest more-keys)
+  (if more-keys
+      (setf (cdr (assoc (car (last more-keys))
+                        (apply #'at doc key (butlast more-keys))
+                        :test #'equal))
+            new-value)
+      (setf (cdr (assoc key doc :test #'equal)) new-value)))
+
+;; A playful alias.
+(defun @ (doc &rest keys)
+  (apply #'at doc keys))
+(defun (setf @) (new-value doc key &rest more-keys)
+  (apply #'(setf at) new-value doc key more-keys))