Sun Apr 12 21:56:34 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Add operator Lisp style functions.
diff -rN -u old-qt.gui/qt.mbd new-qt.gui/qt.mbd
--- old-qt.gui/qt.mbd 2014-10-30 07:44:12.000000000 +0100
+++ new-qt.gui/qt.mbd 2014-10-30 07:44:12.000000000 +0100
@@ -44,6 +44,7 @@
("qt" (:needs "package" "lib"))
("object" (:needs "qt"))
+ ("operator" (:needs "qt" "object"))
("application" (:needs "qt"))
("qstring" (:needs "qt"))
("msg-handler" (:needs "lib"))
diff -rN -u old-qt.gui/src/operator.lisp new-qt.gui/src/operator.lisp
--- old-qt.gui/src/operator.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.gui/src/operator.lisp 2014-10-30 07:44:12.000000000 +0100
@@ -0,0 +1,92 @@
+(in-package :qt)
+
+(defun cxx:= (object &rest more-objects)
+ (if (null more-objects)
+ t
+ (every #'(lambda (o)
+ (qt:operator== object o))
+ more-objects)))
+
+(defun cxx:/= (object &rest more-objects)
+ (if (null more-objects)
+ t
+ (some #'(lambda (o)
+ (qt:operator!= object o))
+ more-objects)))
+
+(defun ordered-p (relation list)
+ "Returns true when LIST is ordered according to RELATION."
+ (if (or (null list) (null (rest list)))
+ t
+ (and (funcall relation (first list)
+ (second list))
+ (ordered-p relation (rest list)))))
+
+(defmacro define-cxx-relation (relation)
+ `(defun ,(intern (symbol-name relation) :cxx) (object &rest more-objects)
+ (ordered-p (symbol-function (quote ,(intern (format nil "OPERATOR~A"
+ relation)
+ :qt)))
+ (cons object more-objects))))
+
+(defmacro define-cxx-relations (&rest relations)
+ `(progn
+ ,@(mapcar #'(lambda (r) `(define-cxx-relation ,r)) relations)))
+
+(define-cxx-relations < <= => >)
+
+
+(defun cxx:incf (object &optional (delta 1))
+ (cxx:operator+= object delta))
+
+(defun cxx:decf (object &optional (delta 1))
+ (cxx:operator-= object delta))
+
+(defun cxx:+ (&rest args)
+ (if (null args)
+ 0
+ (reduce #'qt:operator+ args)))
+
+(defun cxx:- (object &rest subtrahends)
+ (if (null subtrahends)
+ (cxx:operator- object)
+ (reduce #'qt:operator- (cons object subtrahends))))
+
+(defun cxx:* (&rest args)
+ (if (null args)
+ 1
+ (reduce #'qt:operator- args)))
+
+(defun cxx:/ (object &rest denominators)
+ (if (null denominators)
+ (qt:operator/ 1 object)
+ (qt:operator/ object (apply #'cxx:+ denominators))))
+
+(defun cxx:1+ (object)
+ (qt:operator+ object 1))
+
+(defun cxx:1- (object)
+ (qt:operator- object 1))
+
+(defun cxx:aref (object index)
+ "Returns the element of OBJECT at position INDEX."
+ ;;FIXME smoke does not support casting operators => can not
+ ;; return a useful value with operator[]."
+ ;;(cxx:operator[] object index))
+ (declare ((integer 0) index))
+ (assert (< index (cxx:size object))
+ (index)
+ "Index ~A for ~A requested, but the length is ~A"
+ index object (cxx:size object))
+ (cxx:at object index))
+
+
+(defun (setf cxx:aref) (new-value object index)
+ (declare ((integer 0) index))
+ (assert (< index (cxx:size object))
+ (index)
+ "Index ~A for ~A requested, but the length is ~A"
+ index object (cxx:size object))
+ (cxx:operator= (cxx:operator[] object index)
+ new-value)
+ new-value)