Add mechanism for transforming objects to different types

wip-duuqnd/user-side-compiler/transform.lisp

@@ -0,0 +1,71 @@
+(in-package #:user-side-compiler)
+
+(defgeneric %direct-transform (obj to-type)
+  (:method (obj to-type)
+    (error "No direct transformation exists from ~A to ~A."
+           (type-of obj) to-type)))
+
+(defun transform-matches-p (transform-method from-class to-class)
+  (declare (type standard-method transform-method)
+           (type class from-class)
+           (type class to-class))
+  (let ((specs (c2mop:method-specializers transform-method)))
+    (and (equal (first specs) from-class)
+         (equal (c2mop:eql-specializer-object (second specs))
+                (class-name to-class)))))
+
+(defun direct-transform-exists-p (from-class to-class)
+  (some (lambda (m)
+          (transform-matches-p m from-class to-class))
+        (c2mop:generic-function-methods #'%direct-transform)))
+
+(defun transformations-from (from-type)
+  (loop :with from-class := (find-class from-type)
+        :for m :in (c2mop:generic-function-methods #'%direct-transform)
+        :for specs := (c2mop:method-specializers m)
+        :when (eql (first specs) from-class)
+          :collect (c2mop:eql-specializer-object (second specs))))
+
+(defun transform-path (from-type to-type)
+  "Computes a list of intermediate types that can be transformed through to
+get from FROM-TYPE to TO-TYPE. Returns T if a direct transformation exists
+and NIL if no path exists."
+  (do* ((to-class (find-class to-type))
+        (backlinks '())
+        (stack (list from-type))
+        (current-type (first stack) (first stack))
+        (path '()))
+       ((or (null stack) (not (null path))) path)
+    (cond ((eql :end-of-node current-type)
+           (pop backlinks)
+           (pop stack))
+          ((direct-transform-exists-p (find-class current-type) to-class)
+           (if (eql current-type from-type)
+               (setf path t)
+               (setf path (nreverse (cons current-type backlinks)))))
+          (t
+           (pop stack)
+           (push :end-of-node stack)
+           (unless (eql current-type from-type)
+             (push current-type backlinks))
+           (dolist (m (transformations-from current-type))
+             (push m stack))))))
+
+(defun transform (obj to-type)
+  "When a valid transformation exists, it returns an object of type TO-TYPE
+that has been somehow created using OBJ as a starting point."
+  (let ((path (transform-path (type-of obj) to-type)))
+    (if (listp path)
+        (loop :for intermediate :in path
+              :do (setf obj (%direct-transform obj intermediate))
+              :finally (return (%direct-transform obj to-type)))
+        (%direct-transform obj to-type))))
+
+(defmacro define-transformation ((var-name (from-type to-type)) &body body)
+  "Defines a transformation rule for objects going from FROM-TYPE to TO-TYPE.
+Inside BODY, VAR-NAME is bound to the object being transformed. The body should
+return the result of the transformation."
+  (let ((ignorable-var (gensym)))
+    `(defmethod %direct-transform ((,var-name ,from-type) (,ignorable-var (eql ',to-type)))
+       (declare (ignore ,ignorable-var))
+       ,@body)))

wip-duuqnd/user-side-compiler/user-side-compiler.asd

@@ -4,6 +4,7 @@
   :serial t
   :components
   ((:file "package")
+   (:file "transform")
    (:file "tokenizer")
    (:file "label")
    (:file "high-level")