diff --git a/wip-duuqnd/user-side-compiler/transform.lisp b/wip-duuqnd/user-side-compiler/transform.lisp new file mode 100644 index 0000000..66325f6 --- /dev/null +++ b/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))) diff --git a/wip-duuqnd/user-side-compiler/user-side-compiler.asd b/wip-duuqnd/user-side-compiler/user-side-compiler.asd index 246fd0a..3fa1525 100644 --- a/wip-duuqnd/user-side-compiler/user-side-compiler.asd +++ b/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")