generics.lisp

;; Reader macro for hash tables
;; Following code modified from https://news.ycombinator.com/item?id=1611090

(labels ((in-place-hash (stream char)
           (declare (ignore char))
           (let ((ls (read-delimited-list #\} stream t)))
             (with-gensyms (table)
               `(let ( (,table (make-hash-table :test #'equalp)))
                  ,@(mapcar (lambda (p) `(setf (gethash ,(car p) ,table) ,(cadr p)))
                            ls)
                  ,table)))))
  (set-macro-character #\{ #'in-place-hash))

(set-syntax-from-char #\} #\))


;; Utility Macros

(defmacro sethash ((key val) table)
  `(setf (gethash ,key ,table) ,val))

(defun put-if-absent (key val table)
  (unless (second (multiple-value-list (gethash key table)))
    (setf (gethash key table) val)))
    
;; Utility

(defun transpose (list-of-lists)
  (apply #'mapcar #'list list-of-lists))
  
;; The actual generic system

(let ((type-table {})
      (generic-defs {}))

  (defun construct (type val)
    (unless (gethash type type-table) (error (format nil "Nonexistent type ~a" type)))
    (cons type val))

  (defun define-type (tname)
    (sethash (tname t) type-table))

  (labels ((get-type (object) (car object))
           (get-val (object) (cdr object))
           (apply-generic (name args)
             (let ((types (mapcar #'get-type args))
                   (vals (mapcar #'get-val args)))
               (multiple-value-bind (fn-table exists) (gethash name generic-defs)
                 (unless exists (error (format nil "~a has no specializations" name)))
                 (multiple-value-bind (fn exists) (gethash types fn-table)
                   (unless exists
                     (error (format nil "~a has no definition for ~a" name types)))
                   (apply fn vals))))))

    (defmacro define-generic (name argspecs &body body)
      (put-if-absent (name {}) generic-defs)

      (destructuring-bind
          (arg-types arg-names)
          (transpose argspecs)
        ;; Make sure that all the types actually exist!
        (mapcar (lambda (type)
                  (unless (gethash type type-table)
                    (error (format nil "Nonexistent type ~a" type))))
                arg-types)

        ;; Allows generic functions to access lexical scope
        `(progn (setf (symbol-function ',name) ,(lambda (&rest args) (apply-generic name args)))
                (setf (gethash ',arg-types (gethash ',name ,generic-defs))
                      (lambda ,arg-names ,@body)))))))

;; Example usage

(define-type :int-ends)

(defun make-interval (a b)
  (construct :int-ends (cons a b))

(define-generic lower-bound ((:int-ends x))
  (car x))

(let ((a 3))
  (define-generic use-lexical ((:int-ends x))
    (+ a (cdr x))))

(lower-bound (make-interval 3 4))
;; >> 3
(use-lexical (make-interval 3 4))
;; >> 7