Commit f74942c6 authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

merged.

parents bf551302 b72093ca
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: association-test.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Tests the associations.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2015-02-22 <PJB> Extracted from association.lisp.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2015
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(defpackage "COM.INFORMATIMAGO.CLEXT.ASSOCIATION.TEST"
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.CLEXT.ASSOCIATION"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST")
(:import-from "COM.INFORMATIMAGO.CLEXT.ASSOCIATION"
"ADD-NEW-ELEMENT" "MULTIPLICITY")
(:export "TEST/ALL"
"TEST/ADD-NEW-ELEMENT" "TEST/MULTIPLICITY"))
(in-package "COM.INFORMATIMAGO.CLEXT.ASSOCIATION.TEST")
(define-test test/add-new-element ()
(assert-true (equal '(x) (add-new-element nil 'x)))
(assert-true (equal '(x) (add-new-element nil 'x :test (function equal))))
(assert-true (equal '(x) (add-new-element nil 'x :lessp (function string<))))
(assert-true (equal '(x) (add-new-element (list 'x) 'x)))
(assert-true (equal '(x) (add-new-element (list 'x) 'x :test (function equal))))
(assert-true (equal '(x) (add-new-element (list 'x) 'x :lessp (function string<))))
(progn (let* ((list (list 1 2 3))
(result (add-new-element list 0 :test #'=)))
(assert-true (equal result '(1 2 3 0)))
(assert-true (eql result list)))
(let* ((list (list 1 2 3)) (result (add-new-element list 0)))
(assert-true (equal result '(1 2 3 0)))
(assert-true (eql result list)))
(let* ((list (list 1 2 3))
(result (add-new-element list 4 :lessp #'<)))
(assert-true (equal result '(1 2 3 4)))
(assert-true (eql result list)))
(let* ((list (list 1 2 3))
(result (add-new-element list 1 :lessp #'<)))
(assert-true (equal result '(1 2 3)))
(assert-true (eql result list)))
(let* ((list (list 1 2 3)) (result (add-new-element list 1)))
(assert-true (equal result '(1 2 3)))
(assert-true (eql result list)))
(let* ((list (list 1 2 3))
(result (add-new-element list 1.0 :test #'=)))
(assert-true (equal result '(1 2 3)))
(assert-true (eql result list)))
(let* ((list (list 1 2 3)) (result (add-new-element list 2)))
(assert-true (equal result '(1 2 3)))
(assert-true (eql result list)))
(let* ((list (list 1 2 3))
(result (add-new-element list 2.0 :test #'=)))
(assert-true (equal result '(1 2 3)))
(assert-true (eql result list)))
(let* ((list (list 1 2 3)) (result (add-new-element list 3)))
(assert-true (equal result '(1 2 3)))
(assert-true (eql result list)))
(let* ((list (list 1 2 3))
(result (add-new-element list 3.0 :test #'=)))
(assert-true (equal result '(1 2 3)))
(assert-true (eql result list)))
(let* ((list (list 1 2 4))
(result (add-new-element list 3 :lessp #'<)))
(assert-true (equal result '(1 2 3 4)))
(assert-true (eql result list)))
(let* ((list (list 1 2 4))
(result (add-new-element list 2 :lessp #'<)))
(assert-true (equal result '(1 2 4)))
(assert-true (eql result list)))
(let* ((list (list 1 3 4))
(result (add-new-element list 2 :lessp #'<)))
(assert-true (equal result '(1 2 3 4)))
(assert-true (eql result list)))
(let* ((list (list 1 3 4))
(result (add-new-element list 3 :lessp #'<)))
(assert-true (equal result '(1 3 4)))
(assert-true (eql result list))))
(let ((list (list 2 3 4)))
(assert-true (equal '(1 2 3 4) (add-new-element list 1 :lessp (function <)))))
(let ((list (list 2 3 4)))
(assert-true (equal '(1 2 3 4) (add-new-element list 1 :lessp (function <))))))
(defun test/multiplicity ()
(assert-true (equal (mapcar (lambda (test) (multiple-value-list (multiplicity test)))
'(0 1 2 3
0-1 1-1 0-4 2-4
* 0-* 1-* 4-* ; 34-2
0..1 1..1 0..4 2..4
* 0..* 1..* 4..* ; 34..2
))
'((0 0) (1 1) (2 2) (3 3)
(0 1) (1 1) (0 4) (2 4)
(0 *) (0 *) (1 *) (4 *) ; (34 2)
(0 1) (1 1) (0 4) (2 4)
(0 *) (0 *) (1 *) (4 *) ; (34 2)
))))
(define-test test/all ()
(test/add-new-element)
(test/multiplicity))
;;;; THE END ;;;;
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;; FILE: metamodel-macros.lisp
;;;; LANGUAGE: Common-Lisp
;;;; SYSTEM: Common-Lisp
;;;; USER-INTERFACE: NONE
;;;; DESCRIPTION
;;;;
;;;; Macros definitions for the objecteering metamodel.
;;;;
;;;; AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@anevia.com>
;;;; MODIFICATIONS
;;;; 2009-05-20 <PJB> Adapted these macros for the objecteering metamodel.
;;;; 2009-01-09 <PJB> Added this comment.
;;;; BUGS
;;;; LEGAL
;;;; GPL
;;;;
;;;; Copyright
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License
;;;; as published by the Free Software Foundation; either version
;;;; 2 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be
;;;; useful, but WITHOUT ANY WARRANTY; without even the implied
;;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;; PURPOSE. See the GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public
;;;; License along with this program; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;; *************************************************************************
;;;;FILE: association.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Macros definitions for the objecteering metamodel.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@anevia.com>
;;;;MODIFICATIONS
;;;; 2009-05-20 <PJB> Adapted these macros for the objecteering metamodel.
;;;; 2009-01-09 <PJB> Added this comment.
;;;;BUGS
;;;;LEGAL
;;;; GPL
;;;;
;;;; Copyright
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License
;;;; as published by the Free Software Foundation; either version
;;;; 2 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be
;;;; useful, but WITHOUT ANY WARRANTY; without even the implied
;;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;; PURPOSE. See the GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public
;;;; License along with this program; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;;*************************************************************************
(defpackage "COM.INFORMATIMAGO.CLEXT.ASSOCIATION"
(:use "COMMON-LISP" "CLOSER-MOP")
......@@ -138,70 +138,6 @@ TEST: an equal function. Default EQL.
(push element (cdr cell))))
(return (cdr result)))))))
(defun test/add-new-element ()
(assert (equal '(x) (add-new-element nil 'x)))
(assert (equal '(x) (add-new-element nil 'x :test (function equal))))
(assert (equal '(x) (add-new-element nil 'x :lessp (function string<))))
(assert (equal '(x) (add-new-element (list 'x) 'x)))
(assert (equal '(x) (add-new-element (list 'x) 'x :test (function equal))))
(assert (equal '(x) (add-new-element (list 'x) 'x :lessp (function string<))))
(progn (let* ((list (list 1 2 3))
(result (add-new-element list 0 :test #'=)))
(assert (equal result '(1 2 3 0)))
(assert (eql result list)))
(let* ((list (list 1 2 3)) (result (add-new-element list 0)))
(assert (equal result '(1 2 3 0)))
(assert (eql result list)))
(let* ((list (list 1 2 3))
(result (add-new-element list 4 :lessp #'<)))
(assert (equal result '(1 2 3 4)))
(assert (eql result list)))
(let* ((list (list 1 2 3))
(result (add-new-element list 1 :lessp #'<)))
(assert (equal result '(1 2 3)))
(assert (eql result list)))
(let* ((list (list 1 2 3)) (result (add-new-element list 1)))
(assert (equal result '(1 2 3)))
(assert (eql result list)))
(let* ((list (list 1 2 3))
(result (add-new-element list 1.0 :test #'=)))
(assert (equal result '(1 2 3)))
(assert (eql result list)))
(let* ((list (list 1 2 3)) (result (add-new-element list 2)))
(assert (equal result '(1 2 3)))
(assert (eql result list)))
(let* ((list (list 1 2 3))
(result (add-new-element list 2.0 :test #'=)))
(assert (equal result '(1 2 3)))
(assert (eql result list)))
(let* ((list (list 1 2 3)) (result (add-new-element list 3)))
(assert (equal result '(1 2 3)))
(assert (eql result list)))
(let* ((list (list 1 2 3))
(result (add-new-element list 3.0 :test #'=)))
(assert (equal result '(1 2 3)))
(assert (eql result list)))
(let* ((list (list 1 2 4))
(result (add-new-element list 3 :lessp #'<)))
(assert (equal result '(1 2 3 4)))
(assert (eql result list)))
(let* ((list (list 1 2 4))
(result (add-new-element list 2 :lessp #'<)))
(assert (equal result '(1 2 4)))
(assert (eql result list)))
(let* ((list (list 1 3 4))
(result (add-new-element list 2 :lessp #'<)))
(assert (equal result '(1 2 3 4)))
(assert (eql result list)))
(let* ((list (list 1 3 4))
(result (add-new-element list 3 :lessp #'<)))
(assert (equal result '(1 3 4)))
(assert (eql result list))))
(let ((list (list 2 3 4))) (assert (equal '(1 2 3 4) (add-new-element list 1 :lessp (function <)))))
(let ((list (list 2 3 4))) (assert (equal '(1 2 3 4) (add-new-element list 1 :lessp (function <)))))
:success)
(test/add-new-element)
(eval-when (:load-toplevel :compile-toplevel :execute)
......@@ -257,22 +193,7 @@ RETURN: MIN; MAX"
(min max) "Invalid multiplicity ~A" multiplicity)
(values min max)))
(defun test/multiplicity ()
(assert (equal (mapcar (lambda (test) (multiple-value-list (multiplicity test)))
'(0 1 2 3
0-1 1-1 0-4 2-4
* 0-* 1-* 4-* ; 34-2
0..1 1..1 0..4 2..4
* 0..* 1..* 4..* ; 34..2
))
'((0 0) (1 1) (2 2) (3 3)
(0 1) (1 1) (0 4) (2 4)
(0 *) (0 *) (1 *) (4 *) ; (34 2)
(0 1) (1 1) (0 4) (2 4)
(0 *) (0 *) (1 *) (4 *) ; (34 2)
))))
(defun xor (a b) (if a (not b) b))
(defun imply (p q) (or (not p) q))
......@@ -573,11 +494,6 @@ RETURN: MIN; MAX"
'#:eval-when/functions-for-macro)
(eval-when (:execute)
(test/multiplicity)
'tests) ;; eval-when
(defun convert-to-direct-slot-definition (class canonicalized-slot)
(apply (function make-instance)
(apply (function closer-mop:direct-slot-definition-class) class canonicalized-slot)
......@@ -871,7 +787,6 @@ BUGS: If there is an error in handling one association end, after
#-(and)
(let* ((class-name type))
(let* ((class (find-class class-name))
(slots (mop:compute-slots class)))
(unless (find role slots :key (function mop:slot-description-name))
......
......@@ -645,13 +645,17 @@ RETURN: *character-sets*
(when (cs-lisp-encoding cs)
(let ((charset (find-symbol (first (cs-lisp-encoding cs)) "CHARSET")))
(setf (cs-ranges cs)
#+#.(cl:if (cl:ignore-errors
(cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
#+#.(cl:if #+mocl (cl:and (cl:find-package "SYSTEM")
(cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
#-mocl (cl:ignore-errors
(cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
'(:and) '(:or))
(map 'vector (function char-code)
(system::get-charset-range charset))
#-#.(cl:if (cl:ignore-errors
(cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
#-#.(cl:if #+mocl (cl:and (cl:find-package "SYSTEM")
(cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
#-mocl (cl:ignore-errors
(cl:find-symbol "GET-CHARSET-RANGE" "SYSTEM"))
'(:and) '(:or))
(coerce
(loop
......
This diff is collapsed.
......@@ -32,50 +32,36 @@
;;;; along with this program. If not, see http://www.gnu.org/licenses/
;;;;**************************************************************************
(asdf:defsystem :com.informatimago.clext
;; system attributes:
:description "Common Lisp Extensions."
:long-description "
(asdf:defsystem "com.informatimago.clext"
;; system attributes:
:description "Informatimago Common Lisp Extensions"
:long-description "
This system provides Common-Lisp packages that are mostly portable,
but that use some extensions, packages out of the Common-Lisp
specifications, like GRAY or other portability libraries.
"
:author "Pascal J. Bourguignon <pjb@informatimago.com>"
:maintainer "Pascal J. Bourguignon <pjb@informatimago.com>"
:licence "AGPL3"
;; component attributes:
:name "Informatimago Common Lisp Extensions"
:version "1.3.2"
:properties ((#:author-email . "pjb@informatimago.com")
(#:date . "Autumn 2010")
((#:albert #:output-dir) . "/tmp/documentation/com.informatimago.clext/")
((#:albert #:formats) . ("docbook"))
((#:albert #:docbook #:template) . "book")
((#:albert #:docbook #:bgcolor) . "white")
((#:albert #:docbook #:textcolor) . "black"))
#+asdf-unicode :encoding #+asdf-unicode :utf-8
:depends-on ("com.informatimago.common-lisp.cesarum"
"com.informatimago.clext.association")
:author "Pascal J. Bourguignon <pjb@informatimago.com>"
:maintainer "Pascal J. Bourguignon <pjb@informatimago.com>"
:licence "AGPL3"
;; component attributes:
:version "1.3.2"
:properties ((#:author-email . "pjb@informatimago.com")
(#:date . "Autumn 2010")
((#:albert #:output-dir) . "/tmp/documentation/com.informatimago.clext/")
((#:albert #:formats) . ("docbook"))
((#:albert #:docbook #:template) . "book")
((#:albert #:docbook #:bgcolor) . "white")
((#:albert #:docbook #:textcolor) . "black"))
#+asdf-unicode :encoding #+asdf-unicode :utf-8
:depends-on ("com.informatimago.common-lisp.cesarum"
"com.informatimago.clext.association")
:components ((:file "character-sets")
#+(or allegro ccl clisp sbcl cmu)
(:file "closer-weak")))
(:file "closer-weak"))
:in-order-to ((test-op (test-op "com.informatimago.clext.test")
(test-op "com.informatimago.clext.association.test"))))
;;;; THE END ;;;;
......@@ -32,45 +32,57 @@
;;;; along with this program. If not, see http://www.gnu.org/licenses/
;;;;**************************************************************************
(asdf:defsystem :com.informatimago.clext.association
#+mocl
(asdf:defsystem "com.informatimago.clext.association"
;; system attributes:
:description "Dummy Informatimago Common Lisp Extensions: Associations."
:long-description "
;; system attributes:
:description "Common Lisp Extensions: Associations."
This system would use CLOSER-MOP, which is not available on MOCL.
:long-description "
"
:author "Pascal J. Bourguignon <pjb@informatimago.com>"
:maintainer "Pascal J. Bourguignon <pjb@informatimago.com>"
:licence "AGPL3"
;; component attributes:
:version "1.0.0"
:properties ((#:author-email . "pjb@informatimago.com")
(#:date . "Autumn 2010")
((#:albert #:output-dir) . "/tmp/documentation/com.informatimago.clext/")
((#:albert #:formats) . ("docbook"))
((#:albert #:docbook #:template) . "book")
((#:albert #:docbook #:bgcolor) . "white")
((#:albert #:docbook #:textcolor) . "black"))
#+asdf-unicode :encoding #+asdf-unicode :utf-8
:depends-on ()
:components ())
#-mocl
(asdf:defsystem "com.informatimago.clext.association"
;; system attributes:
:description "Informatimago Common Lisp Extensions: Associations."
:long-description "
This system provides a Common-Lisp package exporting a macro to define
CLOS associations. It uses CLOSER-MOP.
"
:author "Pascal J. Bourguignon <pjb@informatimago.com>"
:maintainer "Pascal J. Bourguignon <pjb@informatimago.com>"
:licence "AGPL3"
;; component attributes:
:name "Informatimago Common Lisp Extensions Associations"
:version "1.0.0"
:properties ((#:author-email . "pjb@informatimago.com")
(#:date . "Autumn 2010")
((#:albert #:output-dir) . "/tmp/documentation/com.informatimago.clext/")
((#:albert #:formats) . ("docbook"))
((#:albert #:docbook #:template) . "book")
((#:albert #:docbook #:bgcolor) . "white")
((#:albert #:docbook #:textcolor) . "black"))
#+asdf-unicode :encoding #+asdf-unicode :utf-8
:depends-on ("closer-mop")
:components ((:file "association")))
:author "Pascal J. Bourguignon <pjb@informatimago.com>"
:maintainer "Pascal J. Bourguignon <pjb@informatimago.com>"
:licence "AGPL3"
;; component attributes:
:version "1.0.0"
:properties ((#:author-email . "pjb@informatimago.com")
(#:date . "Autumn 2010")
((#:albert #:output-dir) . "/tmp/documentation/com.informatimago.clext/")
((#:albert #:formats) . ("docbook"))
((#:albert #:docbook #:template) . "book")
((#:albert #:docbook #:bgcolor) . "white")
((#:albert #:docbook #:textcolor) . "black"))
#+asdf-unicode :encoding #+asdf-unicode :utf-8
:depends-on ("closer-mop")
:components ((:file "association"))
:in-order-to ((test-op (test-op "com.informatimago.clext.association.test"))))
;;;; THE END ;;;;
......
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: com.informatimago.common-lisp.cesarum-test.asd
;;;;FILE: com.informatimago.clext.association.test.asd
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; ASD file to test the com.informatimago.common-lisp.cesarum library.
;;;; ASD file to test the com.informatimago.clext.association library.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2015-01-08 <PJB> Created this .asd file.
;;;; 2010-10-31 <PJB> Created this .asd file.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2015
;;;; Copyright Pascal J. Bourguignon 2010 - 2015
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
......@@ -32,47 +32,36 @@
;;;; along with this program. If not, see http://www.gnu.org/licenses/
;;;;**************************************************************************
#+clisp
(unless custom:*ansi*
(warn "System ~A: clisp should be used with -ansi or (setf custom:*ansi* t) in ~/.clisprc"
:com.informatimago.common-lisp.cesarum-test))
(asdf:defsystem "com.informatimago.common-lisp.cesarum-test"
(asdf:defsystem "com.informatimago.clext.association.test"
;; system attributes:
:description "Tests the cesarum library."
:description "Informatimago Common Lisp Extensions: Associations - Tests."
:long-description "
Tests the system that provides a Common-Lisp package exporting a macro
to define CLOS associations. It uses CLOSER-MOP.
"
:author "Pascal J. Bourguignon <pjb@informatimago.com>"
:maintainer "Pascal J. Bourguignon <pjb@informatimago.com>"
:licence "AGPL3"