misc-code/derive2.lisp

;;;; derive2.lisp
;;;;
;;;; Copyright (c) 2015 Samuel W. Flint <swflint@flintfam.org>

(defpackage #:derive2
  (:use #:cl)
  (:export :derive))

(in-package #:derive2)

;;; "derive2" goes here.

(defvar *rules* '())

(defun generate-match-expression (on arity &optional (type '=))
  (declare (symbol on type)
           (integer arity))
  (case type
    (=
     `(and (eq function ',on)
         (= arg-count ,arity)))
    (>
     `(and (eq function ',on)
         (> arg-count ,arity)))
    (>=
     `(and (eq function ',on)
         (>= arg-count ,arity)))))

(defmacro def-expansion (name (on arity &optional type) (&rest arguments) &body expansion)
  (declare (ignorable name on arity type arguments expansion))
  (let ((match-expression (if type
                              (generate-match-expression on arity type)
                              (generate-match-expression on arity))))
    `(progn
       (push (list ',name
                   (lambda (function &rest arguments &aux (arg-count (length arguments)))
                     ,match-expression)
                   (lambda (,@arguments)
                     ,@expansion))
             *rules*)
       ',name)))

(defun derive (function)
  (declare (cons function))
  (let ((op (first function)))
    (cond
      ((numberp op)
       0)
      ((and (symbolp op)
          (= 1 (length function)))
       1)
      (t
       (let ((expansion-function))
         (loop for (name test expander) in *rules*
            do (if (apply test function)
                   (setf expansion-function expander)))
         (apply expansion-function (rest function)))))))

;;; End derive2