diff --git a/kutils-hash-tables.lisp b/kutils-hash-tables.lisp index 56b252a..37251aa 100644 --- a/kutils-hash-tables.lisp +++ b/kutils-hash-tables.lisp @@ -40,64 +40,52 @@ m))))) (defun enable-hash-table-reader () - "Enables the reader macro #{}# for hash-tables. The resulting -hash-table will use #'equal for equality. For example, + "Enables the reader macro @c(#{}#) for hash-tables. The resulting +hash-table will use @c(#'equal) for equality. For example, +@begin[lang=lisp](code) #{:a :b :c :d}# +@end(code) -will create a hash-table with the keys :a and :c. :a stores the -value :b, and :c stores the value :d. +will create a hash-table with the keys @c(:a) and @c(:c); :@c(a) +stores the value @c(:b), and @c(:c) stores the value @c(:d). " (set-dispatch-macro-character #\# #\{ #'|#{-reader|)) -(defun sethash (k v m) +(defmacro sethash (k v ht) "Convenience notation for setting a value in a hash table." - (setf (gethash k m) v)) + `(setf (gethash ,k ,ht) ,v)) -(defun hashkeys (m) - "Returns a list of the keys in the hash table." +(defun hashkeys (ht) + "Returns a list of the keys in a hash table." (let ((keys '())) (maphash (lambda (k v) (declare (ignore v)) (push k keys)) - m) + ht) keys)) -(defun hash-table-to-alist (m) - "Converts the hash-table given to an alist of (key . value) pairs." +(defun hash-table-to-alist (ht) + "Converts the hash-table argument to an alist of @c((key . value)) +pairs." (let ((alist '())) (maphash (lambda (k v) (let ((elt (cons k v))) (setf alist (cons elt alist)))) - m) + ht) alist)) -(defun alist-to-hash-table (alist) - "Converts the alist to a hash-table." - (let ((m (make-hash-table :test 'equal))) - (dolist (elt alist) - (sethash (car elt) (cdr elt) m)) - m)) - - -(defun copy-hash-table (ht) - (let ((copied (make-hash-table :equal #'equal))) - (maphash (lambda (k v) - (sethash k v copied)) - ht) - copied)) (defun new-hash-table () - "Create a new hash table with the #'equal function as its test." + "Create a new hash table with the @c(#'equal) function as its test." (make-hash-table :test #'equal)) (defmacro with-new-hash-table (htsyms &body body) - "with-new-hash-table creates and binds a new hash table for each of -the symbols in htsyms, executing inside a let form, and returns the -hash table(s). If only one hash table is provided, return it as a -single element; otherwise, return an alist of the symbol names and -hash tables." + "Create and bind a new hash table for each of the symbols in @c(htsyms), +executing inside a let form, and returns the hash table(s). If only +one hash table is provided, return it as a single element; otherwise, +return an alist of the symbol names and hash tables." `(let ,(mapcar (lambda (sym) (list sym (list 'new-hash-table))) htsyms) ,@body @@ -106,3 +94,17 @@ hash tables." `(mapcar #'cons (mapcar #'mksymb (quote ,htsyms)) (list ,@htsyms))))) + +(defun alist-to-hash-table (alist) + "Converts the alist to a hash-table." + (with-new-hash-table (ht) + (dolist (elt alist) + (sethash (car elt) (cdr elt) ht)))) + +(defun copy-hash-table (ht) + "Shallow copy @c(ht)." + (with-new-hash-table (copied) + (maphash (lambda (k v) + (sethash k v copied)) + ht))) + diff --git a/kutils.lisp b/kutils.lisp index 7e361da..ab34f17 100644 --- a/kutils.lisp +++ b/kutils.lisp @@ -71,53 +71,6 @@ additional args provided to the lambda." "Create a keyword from its arguments." (intern (string (apply #'mksymb args)) "KEYWORD")) -(defun build-slot (class-name slot) - (let* ((slot-sym (mksymb slot)) - (accessor (mksymb class-name "-" slot-sym))) - (list slot-sym - :initarg (mkkw slot-sym) - :accessor accessor))) - -(defun build-slot-list (class-name &rest slots) - (mapcar (partial #'build-slot class-name) slots)) - -(defun build-arg-list (slots) - (mapcar (lambda (slot) (list (mkkw slot) (mksymb slot))) slots)) - -(defun inherited-slots (supers) - (mapcar #'closer-mop:slot-definition-name - (flatten - (mapcar #'closer-mop:class-slots - (mapcar (lambda (cls) (find-class cls t nil)) supers))))) - -(defun superclasses (superclasses) - (mapcar #'class-name - (mapcar (lambda (cls) (find-class cls t nil)) - superclasses))) - -(defmacro defclass! (name superclass-spec slots &body body) - "Defines a new class and default constructor for name, based on the -superclasses and slots provided. If the first argument to body is a -string, it will be used as the class's docstring." - (let* ((name (mksymb name)) - (docstring (if (stringp (first body)) - (list :documentation (first body)) - (list :documentation (format nil"Automatically generated class.")))) - (supers (superclasses superclass-spec)) - (body (if docstring (rest body) body)) - (ctor (mksymb "make-" name)) - (all-slots (flatten (append (inherited-slots supers) slots)))) - (format t "supers: ~A~%" supers) - `(progn - (closer-mop:ensure-finalized - (defclass ,name ,supers - ,(loop for slot in slots collecting - (list slot :initarg (mksymb slot) - :accessor (mksymb name #\- slot))) - ,docstring - ,@body)) - t))) - (defun zip (&rest lsts) "Zip together elements from each list: (zip '(a b c) '(1 2 3)) produces '((a 1) (b 2) (c 3))." @@ -143,10 +96,24 @@ produces '((a 1) (b 2) (c 3))." `(map 'vector ,fn ,@vecs)) (defun build-vector (arg) - "If @c(arg) is an atom, create a vector for it." + "If @c(arg) is an atom, return it as a list. If it's a list, +coerce it to a vector. If it's a vector, return the +vector. Otherwise, attempt to map it into a vector." (cond ((listp arg) (apply #'vector arg)) ((vectorp arg) arg) - (otherwise (mapv #'identity arg)))) + ((atom arg) + (let ((v (new-vector))) + (vector-push-extend arg v) + v)) + (t (mapv #'identity arg)))) + +(defun extend-vector (v) + "Create a new vector from the contents of its argument where the +new vector is adjustable and has a fill pointer set." + (make-array (length v) + :adjustable t + :initial-contents v + :fill-pointer t)) (defmacro assoc-val (item alist &rest key-args) "Return the value of @c(item) in @c(alist). @c(key-args) should diff --git a/package.lisp b/package.lisp index 31a086f..d08e6b9 100644 --- a/package.lisp +++ b/package.lisp @@ -21,19 +21,20 @@ #:macroexpand-n #:mksymb #:mkkw - #:defclass! #:zip #:new-vector #:mapv #:build-vector + #:extend-vector #:assoc-val ;; kutils-hash-tables.lisp #:enable-hash-table-reader #:hashkeys #:sethash - #:hash-table-to-alist - #:alist-to-hash-table #:new-hash-table #:with-new-hash-table + #:copy-hash-table + #:hash-table-to-alist + #:alist-to-hash-table ))