Skip to content

Commit

Permalink
Move macros from order.lisp to their own file
Browse files Browse the repository at this point in the history
  • Loading branch information
@pfdietz
pfdietz committed Jan 5, 2020
1 parent 4462e5d commit a692b5c
Show file tree
Hide file tree
Showing 2 changed files with 120 additions and 116 deletions.
119 changes: 119 additions & 0 deletions Code/order-macros.lisp
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,119 @@
(in-package :fset)

;;; Macros moved from order.lisp

;;; Makes it easy to define `compare' methods on new classes. Just say:
;;;
;;; (defmethod compare ((f1 frob) (f2 frob))
;;; (compare-slots f1 f2 'foo #'frob-bar))
;;;
;;; where `foo' is a slot and `frob-bar' is an accessor (or any other
;;; function on your class).
;;;
;;; If you want distinct instances to never compare `:equal', put `:eql'
;;; at the end of the accessor list to specify that `eql' is the final
;;; determiner of equality for your type:
;;;
;;; (defmethod compare ((f1 frob) (f2 frob))
;;; (compare-slots f1 f2 'foo #'frob-bar :eql))
;;;

(defmacro compare-slots (obj1 obj2 &rest accessors)
"A handy macro for writing the bodies of `compare' methods for user classes.
Returns the result of comparing the two objects by comparing the results of
calling each of `accessors', in order, on the objects. Despite the name, an
accessor can actually be any function on the class in question; it can also
be a symbol, which will be used to access the slot via `slot-value'. For
example, if class `frob' has accessor `frob-foo' and slot `bar':
(defmethod compare ((f1 frob) (f2 frob))
(compare-slots f1 f2 #'frob-foo 'bar))
If the symbol `:eql' is supplied as the last accessor, then if the comparisons
by the other supplied accessors all return `:equal' but `obj1' and `obj2' are
not eql, this returns `:unequal'."
(let ((default-var (gensym "DEFAULT-"))
(comp-var (gensym "COMP-"))
(obj1-var (gensym "OBJ1-"))
(obj2-var (gensym "OBJ2-")))
(labels ((rec (accs)
(if (or (null accs)
(and (eq (car accs) ':eql)
(or (null (cdr accs))
(error "If ~S is supplied to ~S, it must be ~
the last argument"
':eql 'compare-slots))))
default-var
`(let ((,comp-var (compare ,(call (car accs) obj1-var)
,(call (car accs) obj2-var))))
(if (or (eq ,comp-var ':less) (eq ,comp-var ':greater))
,comp-var
(let ((,default-var (if (eq ,comp-var ':unequal)
':unequal ,default-var)))
,(rec (cdr accs)))))))
(call (fn arg)
;; Makes the expansion more readable, if nothing else
(cond ((and (listp fn)
(eq (car fn) 'function))
`(,(cadr fn) ,arg))
((and (listp fn)
(eq (car fn) 'lambda))
`(,fn ,arg))
((and (listp fn)
(eq (car fn) 'quote)
(symbolp (cadr fn)))
`(slot-value ,arg ,fn))
(t `(funcall ,fn ,arg)))))
`(let ((,obj1-var ,obj1)
(,obj2-var ,obj2)
(,default-var ,(if (member ':eql accessors) '':unequal '':equal)))
(if (eql ,obj1-var ,obj2-var) ':equal
,(rec accessors))))))

(eval-when (:compile-toplevel :load-toplevel :execute)
(deflex +Master-Type-Ordering+ nil
"Keeps track of the types for which explicit cross-comparison methods have
been generated, and against which subsequent such methods will be generated.
This is a list in reverse order."))

;;; Handy macro to generate the cross-comparison methods.
(defmacro define-cross-type-compare-methods (type)
"Generates cross-type comparison methods for `type' against the types on
which the macro has previously been invoked. This macro is intended to be
invoked at the top level of a source file. You should make sure that calls
to this macro are always compiled in the same order; if you don't, you could
possibly get a \"master type ordering out of sync\" error, at which point you
should delete all your fasls, restart your Lisp session, and recompile.
However, the implementation tries very hard to prevent this."
(unless (symbolp type)
(error "Type name required, not ~S" type))
;; Have to add it to the list, if it's not there, at both expansion time and
;; load time.
(pushnew type +Master-Type-Ordering+)
(let ((types (member type +Master-Type-Ordering+))
((prev-types (cdr types))))
`(progn
(let ((mto-len (length +Master-Type-Ordering+)))
(unless (if (< mto-len ,(length types))
(equal +Master-Type-Ordering+
(cl:subseq ',prev-types (- ,(length prev-types) mto-len)))
(equal (cl:subseq +Master-Type-Ordering+
(- mto-len ,(length types)))
',types))
;; This can happen if calls to this macro are compiled in a different
;; order on different occasions, but only if neither call has been loaded.
(error "FSet master type ordering out of sync.~@
See fset::define-cross-type-compare-methods.")))
(unless (member ',type +Master-Type-Ordering+)
;; You might think we would set it to the full expansion-time value,
;; but that would cause problems if FSet is recompiled in a session
;; in which this macro has been invoked on other types -- it would cause
;; this fasl to contain symbols from those packages.
(setq +Master-Type-Ordering+ ',types))
. ,(cl:reduce #'append
(mapcar (lambda (type2)
`((defmethod compare ((a ,type2) (b ,type))
':less)
(defmethod compare ((a ,type) (b ,type2))
':greater)))
prev-types)))))
117 changes: 1 addition & 116 deletions Code/order.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,73 +30,7 @@ and no more than one of A and B can compare `:equal' to C."))
(or (eql a b)
(eq (compare a b) ':equal)))

;;; Makes it easy to define `compare' methods on new classes. Just say:
;;;
;;; (defmethod compare ((f1 frob) (f2 frob))
;;; (compare-slots f1 f2 'foo #'frob-bar))
;;;
;;; where `foo' is a slot and `frob-bar' is an accessor (or any other
;;; function on your class).
;;;
;;; If you want distinct instances to never compare `:equal', put `:eql'
;;; at the end of the accessor list to specify that `eql' is the final
;;; determiner of equality for your type:
;;;
;;; (defmethod compare ((f1 frob) (f2 frob))
;;; (compare-slots f1 f2 'foo #'frob-bar :eql))
;;;
(defmacro compare-slots (obj1 obj2 &rest accessors)
"A handy macro for writing the bodies of `compare' methods for user classes.
Returns the result of comparing the two objects by comparing the results of
calling each of `accessors', in order, on the objects. Despite the name, an
accessor can actually be any function on the class in question; it can also
be a symbol, which will be used to access the slot via `slot-value'. For
example, if class `frob' has accessor `frob-foo' and slot `bar':
(defmethod compare ((f1 frob) (f2 frob))
(compare-slots f1 f2 #'frob-foo 'bar))
If the symbol `:eql' is supplied as the last accessor, then if the comparisons
by the other supplied accessors all return `:equal' but `obj1' and `obj2' are
not eql, this returns `:unequal'."
(let ((default-var (gensym "DEFAULT-"))
(comp-var (gensym "COMP-"))
(obj1-var (gensym "OBJ1-"))
(obj2-var (gensym "OBJ2-")))
(labels ((rec (accs)
(if (or (null accs)
(and (eq (car accs) ':eql)
(or (null (cdr accs))
(error "If ~S is supplied to ~S, it must be ~
the last argument"
':eql 'compare-slots))))
default-var
`(let ((,comp-var (compare ,(call (car accs) obj1-var)
,(call (car accs) obj2-var))))
(if (or (eq ,comp-var ':less) (eq ,comp-var ':greater))
,comp-var
(let ((,default-var (if (eq ,comp-var ':unequal)
':unequal ,default-var)))
,(rec (cdr accs)))))))
(call (fn arg)
;; Makes the expansion more readable, if nothing else
(cond ((and (listp fn)
(eq (car fn) 'function))
`(,(cadr fn) ,arg))
((and (listp fn)
(eq (car fn) 'lambda))
`(,fn ,arg))
((and (listp fn)
(eq (car fn) 'quote)
(symbolp (cadr fn)))
`(slot-value ,arg ,fn))
(t `(funcall ,fn ,arg)))))
`(let ((,obj1-var ,obj1)
(,obj2-var ,obj2)
(,default-var ,(if (member ':eql accessors) '':unequal '':equal)))
(if (eql ,obj1-var ,obj2-var) ':equal
,(rec accessors))))))

;;; The macro definition of compare-slots has been moved to order-macros.lisp

;;; Abstract classes

Expand Down Expand Up @@ -202,55 +136,6 @@ This is the right choice for the vast majority of mutable classes."))
;; be better??).
':unequal))))


(eval-when (:compile-toplevel :load-toplevel :execute)
(deflex +Master-Type-Ordering+ nil
"Keeps track of the types for which explicit cross-comparison methods have
been generated, and against which subsequent such methods will be generated.
This is a list in reverse order."))

;;; Handy macro to generate the cross-comparison methods.
(defmacro define-cross-type-compare-methods (type)
"Generates cross-type comparison methods for `type' against the types on
which the macro has previously been invoked. This macro is intended to be
invoked at the top level of a source file. You should make sure that calls
to this macro are always compiled in the same order; if you don't, you could
possibly get a \"master type ordering out of sync\" error, at which point you
should delete all your fasls, restart your Lisp session, and recompile.
However, the implementation tries very hard to prevent this."
(unless (symbolp type)
(error "Type name required, not ~S" type))
;; Have to add it to the list, if it's not there, at both expansion time and
;; load time.
(pushnew type +Master-Type-Ordering+)
(let ((types (member type +Master-Type-Ordering+))
((prev-types (cdr types))))
`(progn
(let ((mto-len (length +Master-Type-Ordering+)))
(unless (if (< mto-len ,(length types))
(equal +Master-Type-Ordering+
(cl:subseq ',prev-types (- ,(length prev-types) mto-len)))
(equal (cl:subseq +Master-Type-Ordering+
(- mto-len ,(length types)))
',types))
;; This can happen if calls to this macro are compiled in a different
;; order on different occasions, but only if neither call has been loaded.
(error "FSet master type ordering out of sync.~@
See fset::define-cross-type-compare-methods.")))
(unless (member ',type +Master-Type-Ordering+)
;; You might think we would set it to the full expansion-time value,
;; but that would cause problems if FSet is recompiled in a session
;; in which this macro has been invoked on other types -- it would cause
;; this fasl to contain symbols from those packages.
(setq +Master-Type-Ordering+ ',types))
. ,(cl:reduce #'append
(mapcar (lambda (type2)
`((defmethod compare ((a ,type2) (b ,type))
':less)
(defmethod compare ((a ,type) (b ,type2))
':greater)))
prev-types)))))

;;; CL types
(define-cross-type-compare-methods null)
(define-cross-type-compare-methods real)
Expand Down

0 comments on commit a692b5c

Please sign in to comment.