expansion.lisp

;    (definstance (ord string)
;      (defun = (x y) (string= x y))
;      (defun > (x y) (string> x y)))
(PROGN
 (FTYPE =/STRING/STRING STRING STRING BOOLEAN)
 (DEFUN =/STRING/STRING (X Y) (STRING= X Y))
 (DEFINE-COMPILER-HINT =
     (X Y &ENVIRONMENT #:ENV1822)
     (STRING STRING BOOLEAN)
   (IF (AND (FORM-TYPEP X 'STRING #:ENV1822) (FORM-TYPEP Y 'STRING #:ENV1822))
       `(,'=/STRING/STRING ,X ,Y)
       (DECLINE-EXPANSION "expansion of ~a into ~a fails" '=
                          '=/STRING/STRING)))
 (MACROLET ((= (X Y)
              `(,'=/STRING/STRING ,X ,Y)))
   (FTYPE >/STRING/STRING STRING STRING BOOLEAN)
   (DEFUN >/STRING/STRING (X Y) (STRING> X Y))
   (DEFINE-COMPILER-HINT >
       (X Y &ENVIRONMENT #:ENV1821)
       (STRING STRING BOOLEAN)
     (IF (AND (FORM-TYPEP X 'STRING #:ENV1821)
              (FORM-TYPEP Y 'STRING #:ENV1821))
         `(,'>/STRING/STRING ,X ,Y)
         (DECLINE-EXPANSION "expansion of ~a into ~a fails" '>
                            '>/STRING/STRING)))
   (MACROLET ((> (X Y)
                `(,'>/STRING/STRING ,X ,Y)))
     (FTYPE </STRING/STRING STRING STRING BOOLEAN)
     (DEFUN </STRING/STRING (X Y) (> Y X))
     (DEFINE-COMPILER-HINT <
         (X Y &ENVIRONMENT #:ENV1820)
         (STRING STRING BOOLEAN)
       (IF (AND (FORM-TYPEP X 'STRING #:ENV1820)
                (FORM-TYPEP Y 'STRING #:ENV1820))
           `(,'</STRING/STRING ,X ,Y)
           (DECLINE-EXPANSION "expansion of ~a into ~a fails" '<
                              '</STRING/STRING)))
     (MACROLET ((< (X Y)
                  `(,'</STRING/STRING ,X ,Y)))
       (FTYPE >=/STRING/STRING STRING STRING BOOLEAN)
       (DEFUN >=/STRING/STRING (X Y) (OR (> Y X) (= Y X)))
       (DEFINE-COMPILER-HINT >=
           (X Y &ENVIRONMENT #:ENV1819)
           (STRING STRING BOOLEAN)
         (IF (AND (FORM-TYPEP X 'STRING #:ENV1819)
                  (FORM-TYPEP Y 'STRING #:ENV1819))
             `(,'>=/STRING/STRING ,X ,Y)
             (DECLINE-EXPANSION "expansion of ~a into ~a fails" '>=
                                '>=/STRING/STRING)))
       (MACROLET ((>= (X Y)
                    `(,'>=/STRING/STRING ,X ,Y)))
         (FTYPE <=/STRING/STRING STRING STRING BOOLEAN)
         (DEFUN <=/STRING/STRING (X Y) (OR (< Y X) (= Y X)))
         (DEFINE-COMPILER-HINT <=
             (X Y &ENVIRONMENT #:ENV1818)
             (STRING STRING BOOLEAN)
           (IF (AND (FORM-TYPEP X 'STRING #:ENV1818)
                    (FORM-TYPEP Y 'STRING #:ENV1818))
               `(,'<=/STRING/STRING ,X ,Y)
               (DECLINE-EXPANSION "expansion of ~a into ~a fails" '<=
                                  '<=/STRING/STRING)))
         (MACROLET ((<= (X Y)
                      `(,'<=/STRING/STRING ,X ,Y)))
           (FTYPE !=/STRING/STRING STRING STRING BOOLEAN)
           (DEFUN !=/STRING/STRING (X Y) (COMMON-LISP:NOT (= X Y)))
           (DEFINE-COMPILER-HINT !=
               (X Y &ENVIRONMENT #:ENV1817)
               (STRING STRING BOOLEAN)
             (IF (AND (FORM-TYPEP X 'STRING #:ENV1817)
                      (FORM-TYPEP Y 'STRING #:ENV1817))
                 `(,'!=/STRING/STRING ,X ,Y)
                 (DECLINE-EXPANSION "expansion of ~a into ~a fails" '!=
                                    '!=/STRING/STRING)))
           (MACROLET ((!= (X Y) `(,'!=/STRING/STRING ,X ,Y))))))))))

source.lisp

(test eq
  (finishes
    (define-type-class (eq <t>) ()
      (ftype = <t> <t> boolean)
      (ftype != <t> <t> boolean)
      ;; default method
      (defun = (x y) (cl:eq x y))
      ;; not that the = below expands to the actual instance of =, not cl:=
      (defun != (x y) (cl:not (= x y))))))
(test ord
  (finishes
    (define-type-class (ord <s>) (eq)
      (ftype > <s> <s> boolean)
      (ftype < <s> <s> boolean)
      (ftype >= <s> <s> boolean)
      (ftype <= <s> <s> boolean)
      ;; default method for > is missing. therefore
      ;; providing > is mandatory
      (defun < (x y) (> y x))
      (defun >= (x y) (or (> y x) (= y x)))
      (defun <= (x y) (or (< y x) (= y x)))))
  (signals error
    (macroexpand
     '(define-type-class (bogus <s> <s>) (ord)))))

(test ground  
  (finishes
    (definstance (ord fixnum)
      (defun = (x y) (cl:= x y))
      (defun > (x y) (cl:> x y))))
  (finishes
    (definstance (ord string)
      (defun = (x y) (string= x y))
      (defun > (x y) (string> x y)))))