74 lines
3.1 KiB
Common Lisp
74 lines
3.1 KiB
Common Lisp
(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-type)
|
|
(some (lambda (m)
|
|
(transform-matches-p m (find-class from-class) to-type))
|
|
(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 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* ((from-type (case (type-of obj)
|
|
((bit number integer fixnum) 'integer)
|
|
(t (type-of obj))))
|
|
(path (transform-path from-type 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)))
|