|
|
@@ -0,0 +1,59 @@
|
|
|
+;;;; 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
|
