1: ;;;
    2: ;;; tests for some builtin list operations
    3: ;;;
    4: 
    5: ;; $Id: list.scm,v 1.5 2003/12/08 08:38:31 shirok Exp $
    6: 
    7: (use gauche.test)
    8: 
    9: ;; monotonic-merge is a core function to implement Dylan-style class
   10: ;; precedence list.  those tests are taken from examples in
   11: ;;   http://www.webcom.com/~haahr/dylan/linearization-oopsla96.html
   12: 
   13: (define (get-super elt)
   14:   (let ((p (assq elt
   15:                  '((popup-menu menu popup-mixin)
   16:                    (menu choice-widget)
   17:                    (popup-mixin object)
   18:                    (pedalo pedal-wheel-boat small-catamaran)
   19:                    (pedal-wheel-boat engineless wheel-boat)
   20:                    (engineless day-boat)
   21:                    (day-boat boat)
   22:                    (boat object)
   23:                    (wheel-boat boat)
   24:                    (small-catamaran small-multihull)
   25:                    (small-multihull day-boat)
   26:                    (confused-grid hv-grid vh-grid)
   27:                    (hv-grid horizontal-grid vertical-grid)
   28:                    (vh-grid vertical-grid horizontal-grid)
   29:                    (horizontal-grid grid-layout)
   30:                    (vertical-grid grid-layout)
   31:                    (grid-layout object)))))
   32:     (if (pair? p) (cdr p) #f)))
   33: 
   34: (test "monotonic-merge"
   35:       '(popup-menu menu choice-widget popup-mixin object)
   36:       (lambda ()
   37:         (monotonic-merge
   38:          'popup-menu
   39:          '((menu choice-widget object)
   40:            (menu popup-mixin)
   41:            (popup-mixin object))
   42:          get-super)))
   43: 
   44: (test "monotonic-merge"
   45:       '(pedalo pedal-wheel-boat engineless small-catamaran
   46:         small-multihull day-boat wheel-boat boat object)
   47:       (lambda ()
   48:         (monotonic-merge
   49:          'pedalo
   50:          '((pedal-wheel-boat engineless day-boat wheel-boat boat object)
   51:            (small-catamaran small-multihull day-boat boat object)
   52:            (pedal-wheel-boat small-catamaran))
   53:          get-super)))
   54: 
   55: (test "monotonic-merge"
   56:       #f
   57:       (lambda ()
   58:         (monotonic-merge
   59:          'confused-grid
   60:          '((hv-grid vh-grid)
   61:            (hv-grid horizontal-grid vertical-grid grid-layout object)
   62:            (vh-grid vertical-grid horizontal-grid grid-layout object))
   63:          get-super)))
   64: 
   65: