From 22686584f103d163a1e5f370aa06905ec5c3b4a4 Mon Sep 17 00:00:00 2001 From: colin Date: Mon, 17 Jun 2024 21:13:41 -0700 Subject: Inital Commit --- README.md | 66 ++++++++++++++++++++++++++++++++++++++ def.asd | 11 +++++++ def.lisp | 101 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ package.lisp | 6 ++++ util.lisp | 36 +++++++++++++++++++++ 5 files changed, 220 insertions(+) create mode 100644 README.md create mode 100644 def.asd create mode 100644 def.lisp create mode 100644 package.lisp create mode 100644 util.lisp diff --git a/README.md b/README.md new file mode 100644 index 0000000..bfe785c --- /dev/null +++ b/README.md @@ -0,0 +1,66 @@ +# `def` + +A stupid project to dull the pain of using a few of CL's built-in `def*` forms. + +## `def:var` + +Isn't it annoying that, if you want to leave a `defvar`-defined +special variable uninitialized at the top-level, then you're not +allowed to give that variable a docstring? + +Sure, you can always + + (setf (documentation *my-speical* 'variable) "oh good, docs") + +but that's irritating too. + +Enter `def:var` + + + (def:var *oh-so-special* :doc "It's oh-so-special") + +Of course, you may still initialize the variable: + + (def:var *oh-so-special* :init (random 10) :doc "It's oh-so-special") + +## `def:const` + +Even more obnoxious is the behavior of `defconst` whenever you `C-c +C-c` in SLIME. You nearly always find yourself invoking a `CONTINUE` +restart when, according to common sense, you should not have had to. + +Well no more! + + (def:const +its-ten+ 10 "It's just the number 10") + +If you re-evaluate that form, then nothing annoying happens. Of +course, the form still expands out to `defconstant` so that a +condition signals whenever you try to `setf` the name. + +## `def:class` + +Admittedly, this one is less justfifed. There's already the extremely +elaborate `defclass/std` in the `defclass-std` system available +through quicklisp. But I think `defclass/std` is a little *too* +thorough and ends up getting in its own way. + +The case for using a macro like this is that, well, most classes are +defined in a very repetitive way. This macro just saves you some +work: + + (def:class pt () + (x y z :prefix :type real :initform 0) + (uuid :ro :type integer :initform (make-uuid) :documentation "A unique ID") + :documentation "A point in real 3d space") + +The above would expand out into + + (DEFCLASS PT NIL + ((X :ACCESSOR PT-X :INITARG :X :TYPE REAL :INITFORM 0) + (Y :ACCESSOR PT-Y :INITARG :Y :TYPE REAL :INITFORM 0) + (Z :ACCESSOR PT-Z :INITARG :Z :TYPE REAL :INITFORM 0) + (UUID :READER UUID :INITARG :UUID :TYPE INTEGER :INITFORM + (MAKE-UUID) :DOCUMENTATION "A unique ID")) + (:DOCUMENTATION "A point in real 3d space")) + +See `def:class`'s docstring for details. diff --git a/def.asd b/def.asd new file mode 100644 index 0000000..bd760e1 --- /dev/null +++ b/def.asd @@ -0,0 +1,11 @@ +;;;; def.asd + +(asdf:defsystem #:def + :description "Macros Making def* forms nicer to use." + :author "colin " + :license "Unlicense" + :version "0.0.1" + :serial t + :components ((:file "package") + (:file "util") + (:file "def"))) diff --git a/def.lisp b/def.lisp new file mode 100644 index 0000000..9944505 --- /dev/null +++ b/def.lisp @@ -0,0 +1,101 @@ +;;;; def.lisp + +(in-package #:def) + +(defmacro var (name &key doc (init nil initp)) + "DEFVAR with optional documentation and optional initform. Lets you +easily document uninitialized special variables." + (assert (good-muffed-var-name-p name) (name) + "Special variable ~s is not wearing earmuffs :(") + `(progn + (defvar ,name) + ,@(when initp + (list `(setf ,name ,init))) + ,@(when doc + (list `(setf (documentation ',name 'cl:variable) ,doc))))) + +(defmacro const (name value &optional doc) + "Define a constant in a way that is redefinable whenever the form is +reevaluated." + (assert (good-muffed-var-name-p name :muffer "+")) + `(progn + (handler-bind ((error + (lambda (&rest ignore) + (declare (ignore ignore)) + (invoke-restart 'cl:continue)))) + (makunbound ',name)) + (defconstant ,name ,value ,@(when doc (list doc))))) + +(defmacro class (name (&rest supers) &body slots-and-options) + "Define a class. + +SLOTS-AND-OPTIONS := (SLOT-SPEC1 ... SLOT-SPECN . CLASS-OPTIONS) + +Each SLOT-SPEC is a list of slot names followed by keyword slot +options, E.g: + +(X Y Z :type real :initform 0) + +Would expand into three slot definitions +(X :accessor X :initarg :X :type real :initform 0) +(Y :accessor Y :initarg :Y :type real :initform 0) +(Z :accessor Z :initarg :Z :type real :initform 0) + +There are a few flag style slot definition arguments. Flags do not +have an value after them, all flags must come before other options. Flags are: + :prefix - prefix the accessor by the class name + :ro - only define a reader + :wo - only define a writer + +By default an accessor is defined. + +CLASS-OPTIONS is a PLIST of class options. + +E.g. + +(def:class pt (thing) + (x y z :prefix :type real :initform 0) + (label :type :string) +" + (labels + ((make-accessor-name (slot &optional prefix?) + (if prefix? + (intern (format nil "~a-~a" name slot)) + slot)) + (singlep (x) + (find x '(:prefix :ro :wo) :test #'eq)) + (parse-slot-spec-expr (expr) + " (names ... &key kwargs)" + (multiple-value-bind (slot-names kwargs) (take-until #'keywordp expr) + (multiple-value-bind (singles kwargs) (partition #'singlep kwargs) + (let ((prefix-accessor? (find ':prefix singles :test #'eq)) + (read-only? (find ':ro singles :test #'eq)) + (write-only? (find ':wo singles :test #'eq))) + (assert (not (and read-only? write-only?)) () + "A slot cannot be both read-only (:ro) and write-only (:wo).") + (loop + :with accessor-type := (cond (read-only? :reader) + (write-only? :writer) + (t :accessor)) + :for slot :in slot-names + :collect `(,slot + ,accessor-type ,(make-accessor-name slot prefix-accessor?) + :initarg ,(alexandria:make-keyword slot) + ,@kwargs)))))) + + (parse-class-options (kwargs) + (loop :for (key val . more) :on kwargs :by #'cddr + :collect (list key val)))) + + (let* ((slot-defs (loop :for expr :in slots-and-options + :while (listp expr) + :append (parse-slot-spec-expr expr))) + (options (parse-class-options + (nth-value 1 (take-until #'keywordp slots-and-options))))) + + `(defclass ,name ,supers + (,@slot-defs) + ,@options)))) + + + diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..779ea68 --- /dev/null +++ b/package.lisp @@ -0,0 +1,6 @@ +;;;; package.lisp + +(defpackage #:def + (:use #:cl) + (:shadow #:var #:class) + (:export #:class #:var #:const)) diff --git a/util.lisp b/util.lisp new file mode 100644 index 0000000..537d85d --- /dev/null +++ b/util.lisp @@ -0,0 +1,36 @@ +(in-package #:def) + + +(defun take-until (pred list) + "Returns two values: FRONT BACK. + +FRONT contains the first N members X of LIST for which (PRED X) is NIL. +BACK contains everything after the members of FRONT. + +(EQUALP LIST + (MULTIPLE-VALUE-BIND (FRONT BACK) (TAKE-UNTIL PRED LIST) + (APPEND FRONT BACK)) + +Is always T." + (loop :for (x . back) :on list + :for fx? := (funcall pred x) + :until fx? + :collect x :into front + :finally (return (values front (if fx? (cons x back) nil))))) + +(defun partition (pred list) + "Returns two list values: YES NO. + +YES is everything for which PRED is T, NO is everything else." + (loop :for e :in list + :when (funcall pred e) + :collect e :into yes + :else + :collect e :into no + :finally (return (values yes no)))) + +(defun good-muffed-var-name-p (name &key (muffer "*")) + (and (symbolp name) + (string= muffer name :end2 (length muffer)) + (string= muffer name :start2 (- (length (symbol-name name)) + (length muffer))))) -- cgit v1.2.3