From 2fd0f0a7f67acb740c274e57c0d1378eb8c75c87 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sat, 27 Jul 2024 15:18:34 -0700
Subject: Add: naive generics

---
 def.asd      |   5 ++-
 generic.lisp | 124 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 package.lisp |   4 +-
 3 files changed, 129 insertions(+), 4 deletions(-)
 create mode 100644 generic.lisp

diff --git a/def.asd b/def.asd
index 95057ae..4209383 100644
--- a/def.asd
+++ b/def.asd
@@ -1,7 +1,7 @@
 ;;;; def.asd
 
 (asdf:defsystem #:def
-  :description "Macros Making def* forms nicer to use."
+  :description "Idomatic def* forms."
   :author "colin <colin@cicadas.surf>"
   :license  "Unlicense"
   :version "0.0.1"
@@ -9,4 +9,5 @@
   :serial t
   :components ((:file "package")
                (:file "util")
-               (:file "def")))
+               (:file "def")
+               (:file "generic")))
diff --git a/generic.lisp b/generic.lisp
new file mode 100644
index 0000000..d160527
--- /dev/null
+++ b/generic.lisp
@@ -0,0 +1,124 @@
+;;;; An implementation of a kind of generic function. This is not
+;;;; terribly CLOSy, as it does not support inheritance. What we have
+;;;; is a method selection routine that works on arbitrary types.
+;;;; Some effort has been made to emulate CLOS's primary method
+;;;; selection.
+
+(in-package :def)
+
+(defvar *genfuns* (make-hash-table :test #'eq)
+  "Mapping from symbol names to GENFUN instances.")
+
+(defclass genfun ()
+  ((name
+    :reader genfun-name
+    :initarg :name 
+    :type symbol)
+   (methods
+    :accessor genfun-methods
+    :type (or null cons)
+    :initform nil
+    :documentation
+    "A sorted association list, keyed by TYPE SPECIFIER, storing
+    S-EXPRESSIONS representing the method implementation for that
+    type. This list is sorted in topological order according the
+    natural order on the type keys.")
+   (lambda-list
+    :reader genfun-lambda-list
+    :initarg :lambda-list
+    :type (or null cons)
+    :documentation
+    "The lambda list for this generic function")
+   (docstring
+    :reader genfun-docstring
+    :initarg :docstring
+    :type (or null string))))
+
+(defun type-specifier-p (thing)
+  (ignore-errors
+   (typep nil thing)
+   t))
+
+(deftype lambda-list-option-term ()
+  '(member cl:&rest cl:&aux cl:&optional cl:&key))
+
+(defun expand-generic-function-def (generic)
+  (let ((vars
+          (method-sig-vars (genfun-lambda-list generic)))
+        (types
+          (gensym "TYPES-")))
+    `(defun ,(genfun-name generic) ,(genfun-lambda-list generic)
+       ,(genfun-docstring generic)
+       (let ((,types (mapcar #'type-of (list ,@vars)))) 
+         (cond
+           ,@(loop :for (signature . body) :in (genfun-methods generic)
+                   :collect `((every #'subtypep ,types ',signature) ,@body) :into clauses
+                   :finally
+                      (return (nconc clauses
+                                 (list
+                                  `(t (error "No implementation of ~s for ~s"
+                                            ',(genfun-name generic)
+                                            ,types)))))))))))
+(defun method-signature (lambda-list)
+  (loop
+    :for param :in lambda-list
+    :until (typep param 'lambda-list-option-term)
+    :when (and (listp param) (= 2 (length param)))
+      :do (assert (type-specifier-p (second param)) ()
+                  "~s is not a valid type-specifier"
+                  (second param))
+      :and :collect (second param)
+    :else
+      :collect 't))
+
+(defun method-sig-vars (gen-lambda-list)
+  (loop :for x :in gen-lambda-list
+        :until (typep x 'lambda-list-option-term)
+        :collect x))
+
+(defun sig-before-p (sig1 sig2)
+  (let* ((before (mapcar #'subtypep sig1 sig2))
+         (after (mapcar #'subtypep sig2 sig1)))
+    (or (every #'identity before)
+        (and (find 't before) (find 't after)
+             (< (position 't before) (position 't after))))))
+
+(defun add-meth (gen spec)
+  (with-slots (methods) gen
+    (push spec methods)
+    (setf methods (sort methods #'sig-before-p :key #'car))))
+
+
+(defun method-lambda-list-matches-generic (mll gll)
+  (and (= (length mll) (length gll))
+       (loop :for m :in mll
+             :for g :in gll
+             :for mvar := (if (consp m) (first m) m)
+             :for gvar := (if (consp g) (first g) g)
+             :always (string-equal mvar gvar))))
+
+(defmacro generic (name lambda-list &optional docstring)
+  "Define a generic function with optional docstring"
+  (expand-generic-function-def
+   (setf (gethash name *genfuns*)
+         (make-instance 'genfun
+           :name name
+           :lambda-list lambda-list
+           :docstring docstring))))
+
+(defmacro method (name lambda-list &body body)
+  "Define a method on the generic function called NAME, which must exist already."
+  (let ((gen (gethash name *genfuns*)))
+    (unless gen
+      (error "Unknown GENFUN named ~s" name))
+    (unless (method-lambda-list-matches-generic lambda-list (genfun-lambda-list gen))
+      (error "Method lambda-list ~s does not match generic function ~s"
+             lambda-list (genfun-lambda-list gen)))
+    (let* ((sig
+             (method-signature lambda-list))
+           (bound
+             (assoc sig (genfun-methods gen) :test #'equalp)))
+      (if bound
+          (rplacd bound body)
+          (add-meth gen (cons sig body)))
+      (expand-generic-function-def gen))))
diff --git a/package.lisp b/package.lisp
index af8d29c..cec336f 100644
--- a/package.lisp
+++ b/package.lisp
@@ -2,5 +2,5 @@
 
 (defpackage #:def
   (:use #:cl)
-  (:shadow #:var #:class)
-  (:export #:class #:var #:const #:fast))
+  (:shadow #:var #:class #:method)
+  (:export #:class #:var #:const #:fast #:generic #:method))
-- 
cgit v1.2.3