home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / run-collections-generic2.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  22.2 KB  |  674 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;*
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;*
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;*
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-collections-generic2.scm,v 1.1 1992/09/18 23:45:58 birkholz Exp $
  39.  
  40. ;;; This file is a continuation of runtime-collections-generic, which had
  41. ;;; to be split because of a limitation in the Gambit compiler.
  42.  
  43. ;;;;
  44. ;;;; FUNCTIONS FOR SEQUENCES (page 104)
  45. ;;;;
  46.  
  47. (define dylan:add
  48.   (dylan::generic-fn 'add one-sequence-and-an-object
  49.     (lambda rest
  50.       (dylan-call dylan:error
  51.           "add -- generic method not specialized for this collection"
  52.           rest))))
  53.  
  54. (define dylan:add!
  55.   (dylan::generic-fn 'add!
  56.       one-sequence-and-an-object
  57.       (lambda (seq obj)
  58.     (dylan-call dylan:add seq obj))))    ; Defaults to ADD
  59.  
  60.  
  61. (define dylan:add-new
  62.   (dylan::generic-fn
  63.    'add-new
  64.    (make-param-list `((SEQUENCE ,<sequence>) (OBJECT ,<object>))
  65.             #F #F '(test:))
  66.    #F))
  67.  
  68. (add-method
  69.  dylan:add-new
  70.  (dylan::dylan-callable->method
  71.   (make-param-list `((SEQUENCE ,<sequence>) (OBJECT ,<object>))
  72.            #F #F '(test:))
  73.   (lambda (multiple-values next-method seq object . rest)
  74.     multiple-values
  75.     (dylan::keyword-validate next-method rest '(test:))
  76.     (let ((test-fn (dylan::find-keyword rest 'test:
  77.                     (lambda () dylan:id?))))
  78.       (if (iterate-until (lambda (x) (dylan-call test-fn x object)) seq)
  79.       seq
  80.       (dylan-call dylan:add seq object))))))
  81.  
  82. (define dylan:add-new!
  83.   (dylan::generic-fn
  84.    'add-new
  85.    (make-param-list `((SEQUENCE ,<sequence>) (OBJECT ,<object>))
  86.             #F #F '(test:))
  87.    #F))
  88.  
  89. (add-method
  90.  dylan:add-new!
  91.  (dylan::dylan-callable->method
  92.   (make-param-list `((SEQUENCE ,<sequence>) (OBJECT ,<object>))
  93.            #F #F '(test:))
  94.   (lambda (multiple-values next-method seq object . rest)
  95.     multiple-values
  96.     (dylan::keyword-validate next-method rest '(test:))
  97.     (let ((test-fn (dylan::find-keyword rest 'test:
  98.                     (lambda () dylan:id?))))
  99.       (if (iterate-until (lambda (x) (dylan-call test-fn x object)) seq)
  100.       seq
  101.       (dylan-call dylan:add! seq object))))))
  102.  
  103. (define dylan:remove
  104.   (dylan::generic-fn
  105.    'remove
  106.    (make-param-list `((SEQUENCE ,<sequence>) (VALUE ,<object>))
  107.             #F #F '(test: count:))
  108.    #F))
  109.  
  110. (add-method
  111.  dylan:remove
  112.  (dylan::dylan-callable->method
  113.   (make-param-list `((SEQUENCE ,<sequence>) (VALUE ,<object>))
  114.            #F #F '(test: count:))
  115.   (lambda (multiple-values next-method seq value . rest)
  116.     multiple-values
  117.     (dylan::keyword-validate next-method rest '(test: count:))
  118.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?)))
  119.       (count (dylan::find-keyword rest 'count: (lambda () -1))))
  120.       (let loop ((state (dylan-call dylan:initial-state seq))
  121.          (result (dylan-call dylan:make
  122.                      (dylan-call dylan:class-for-copy seq)))
  123.          (changed 0))
  124.     (if state
  125.         (let ((cur-element (dylan-call dylan:current-element seq state)))
  126.           (if (and (or (negative? count)
  127.                (< changed count))
  128.                (dylan-call test? cur-element value))
  129.           (loop (dylan-call dylan:next-state seq state)
  130.             result
  131.             (+ changed 1))
  132.           (loop (dylan-call dylan:next-state seq state)
  133.             (dylan-call dylan:add result cur-element)
  134.             changed)))
  135.         (dylan-call dylan:reverse result)))))))
  136.  
  137. (define dylan:remove!
  138.   (dylan::generic-fn
  139.    'remove!
  140.    (make-param-list `((SEQUENCE ,<sequence>) (VALUE ,<object>))
  141.             #F #F '(test: count:))
  142.    #F))
  143.  
  144. (add-method
  145.  dylan:remove!
  146.  (dylan::dylan-callable->method
  147.   (make-param-list `((SEQUENCE ,<sequence>) (VALUE ,<object>))
  148.            #F #F '(test: count:))
  149.   (lambda (multiple-values next-method seq value . rest)
  150.     multiple-values
  151.     (dylan::keyword-validate next-method rest '(test: count:))
  152.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?)))
  153.       (count (dylan::find-keyword
  154.           rest 'count:
  155.           (lambda () (dylan-call dylan:size seq)))))
  156.       (dylan-call dylan:remove seq value 'test: test? 'count: count)))))
  157.  
  158. (define dylan:choose
  159.   (dylan::generic-fn 'choose
  160.     (make-param-list `((PREDICATE ,<function>) (SEQUENCE ,<sequence>)) #F #F #F)
  161.     (lambda (test? seq)
  162.       (let loop ((state (dylan-call dylan:initial-state seq))
  163.          (result (dylan-call dylan:make
  164.                      (dylan-call dylan:class-for-copy seq))))
  165.     (if state
  166.         (let ((cur-element (dylan-call dylan:current-element seq state)))
  167.           (loop (dylan-call dylan:next-state seq state)
  168.             (if (dylan-call test? cur-element)
  169.             (dylan-call dylan:add result cur-element)
  170.             result)))
  171.         (dylan-call dylan:reverse result))))))
  172.  
  173. (define dylan:choose-by
  174.   (dylan::generic-fn 'choose-by
  175.     (make-param-list `((PREDICATE ,<function>)
  176.                (TEST-SEQUENCE ,<sequence>)
  177.                (VALUE-SEQUENCE ,<sequence>)) #F #F #F)
  178.     (lambda (test? test-sequence value-sequence)
  179.       (let loop ((test-state (dylan-call dylan:initial-state test-sequence))
  180.          (value-state (dylan-call dylan:initial-state value-sequence))
  181.          (result (dylan-call dylan:make
  182.                      (dylan-call dylan:class-for-copy
  183.                          value-sequence))))
  184.     (if (and test-state value-state)
  185.         (let ((test-element
  186.            (dylan-call dylan:current-element
  187.                    test-sequence test-state)))
  188.           (loop (dylan-call dylan:next-state test-sequence test-state)
  189.             (dylan-call dylan:next-state value-sequence value-state)
  190.             (if (dylan-call test? test-element)
  191.             (dylan-call dylan:add
  192.                     result
  193.                     (dylan-call dylan:current-element
  194.                         value-sequence value-state))
  195.             result)))
  196.         (dylan-call dylan:reverse result))))))
  197.  
  198. (define dylan:intersection
  199.   ;; Does intersection result in a set whose elements are unique?
  200.   ;; This implementation may result in a multi-set...
  201.   (dylan::generic-fn
  202.    'intersection
  203.    (make-param-list `((SEQUENCE-1 ,<sequence>) (SEQUENCE-2 ,<sequence>))
  204.             #F #F '(test:))
  205.    #F))
  206.  
  207. (add-method
  208.  dylan:intersection
  209.  (dylan::dylan-callable->method
  210.   (make-param-list `((SEQUENCE-1 ,<sequence>) (SEQUENCE-2 ,<sequence>))
  211.            #F #F '(test:))
  212.   (lambda (multiple-values next-method seq-1 seq-2 . rest)
  213.     multiple-values
  214.     (dylan::keyword-validate next-method rest '(test:))
  215.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?))))
  216.       (let loop ((state (dylan-call dylan:initial-state seq-1))
  217.          (result (dylan-call
  218.               dylan:make
  219.               (dylan-call dylan:class-for-copy seq-1))))
  220.     (if state
  221.         (let ((a (dylan-call dylan:current-element seq-1 state)))
  222.           (loop (dylan-call dylan:next-state seq-1 state)
  223.             (if (dylan-call
  224.              dylan:any?
  225.              (make-dylan-callable (lambda (b)
  226.                         (dylan-call test? a b))
  227.                           1)
  228.              seq-2)
  229.             (dylan-call dylan:add result a)
  230.             result)))
  231.         (dylan-call dylan:reverse result)))))))
  232.  
  233. (define dylan:union
  234.   (dylan::generic-fn
  235.    'union
  236.    (make-param-list
  237.     `((SEQUENCE-1 ,<sequence>) (SEQUENCE-2 ,<sequence>)) #F #F '(test:))
  238.    #F))
  239.  
  240. (add-method
  241.  dylan:union
  242.  (dylan::dylan-callable->method
  243.   (make-param-list
  244.    `((SEQUENCE-1 ,<sequence>) (SEQUENCE-2 ,<sequence>)) #F #F '(test:))
  245.   (lambda (multiple-values next-method seq-1 seq-2 . rest)
  246.     multiple-values            ; Ignored
  247.     (dylan::keyword-validate next-method rest '(test:))
  248.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?))))
  249.       (dylan-call dylan:remove-duplicates
  250.           (dylan-call dylan:concatenate
  251.                   (dylan-call dylan:as
  252.                       (dylan-call dylan:class-for-copy
  253.                               seq-1)
  254.                       seq-1)
  255.                   (dylan-call dylan:as
  256.                       (dylan-call dylan:class-for-copy
  257.                               seq-1)
  258.                       seq-2))
  259.           'test: test?)))))
  260.  
  261. (define dylan:remove-duplicates
  262.   (dylan::generic-fn
  263.    'remove-duplicates
  264.    (make-param-list `((SEQUENCE ,<sequence>)) #F #F '(test:))
  265.    #F))
  266.  
  267. (add-method
  268.  dylan:remove-duplicates
  269.  (dylan::dylan-callable->method
  270.   (make-param-list `((SEQUENCE ,<sequence>)) #F #F '(test:))
  271.   (lambda (multiple-values next-method seq . rest)
  272.     multiple-values
  273.     (dylan::keyword-validate next-method rest '(test:))
  274.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?))))
  275.       (let loop ((state (dylan-call dylan:initial-state seq))
  276.          (result (dylan-call dylan:make
  277.                      (dylan-call dylan:class-for-copy seq))))
  278.     (if state
  279.         (let ((cur-element (dylan-call dylan:current-element seq state))
  280.           (result-size (dylan-call dylan:size result)))
  281.           (do ((state-2 (dylan-call dylan:initial-state seq)
  282.                 (dylan-call dylan:next-state seq state-2))
  283.            (count 0 (+ count 1)))
  284.           ((or (>= count result-size)
  285.                (dylan-call test?
  286.                    cur-element
  287.                    (dylan-call dylan:current-element
  288.                            seq state-2)))
  289.            (loop (dylan-call dylan:next-state seq state)
  290.              (if (>= count result-size)
  291.                  (dylan-call dylan:add result cur-element)
  292.                  result)))))
  293.         (dylan-call dylan:reverse result)))))))
  294.  
  295.  
  296. (define dylan:remove-duplicates!
  297.   (dylan::generic-fn
  298.    'remove-duplicates!
  299.    (make-param-list `((SEQUENCE ,<sequence>)) #F #F '(test:))
  300.    #F))
  301.  
  302. (add-method
  303.  dylan:remove-duplicates!
  304.  (dylan::dylan-callable->method
  305.   (make-param-list `((SEQUENCE ,<sequence>)) #F #F '(test:))
  306.   (lambda (multiple-values next-method seq . rest)
  307.     multiple-values
  308.     (dylan::keyword-validate next-method rest '(test:))
  309.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?))))
  310.       (dylan-call dylan:remove-duplicates seq 'test: test?)))))
  311.  
  312. (define dylan:copy-sequence
  313.   (dylan::generic-fn
  314.    'copy-sequence
  315.    (make-param-list `((SOURCE ,<sequence>)) #F #F '(start: end:))
  316.    #F))
  317.  
  318. (add-method
  319.  dylan:copy-sequence
  320.  (dylan::dylan-callable->method
  321.   (make-param-list `((SOURCE ,<sequence>)) #F #F '(start: end:))
  322.   (lambda (multiple-values next-method source . rest)
  323.     multiple-values
  324.     (dylan::keyword-validate next-method rest '(start: end:))
  325.     (let ((start (dylan::find-keyword rest 'start: (lambda () 0)))
  326.       (end (dylan::find-keyword
  327.         rest 'end: (lambda () (dylan-call dylan:size source)))))
  328.       (let loop ((state (dylan-call dylan:initial-state source))
  329.          (result (dylan-call dylan:make
  330.                      (dylan-call
  331.                       dylan:class-for-copy source)))
  332.          (index 0))
  333.     (if (and state (<= index (- end 1)))
  334.         (loop (dylan-call dylan:next-state source state)
  335.           (if (>= index start)
  336.               (dylan-call dylan:add
  337.                   result
  338.                   (dylan-call dylan:current-element
  339.                           source state))
  340.               result)
  341.           (+ index 1))
  342.         (dylan-call dylan:reverse result)))))))
  343.  
  344.  
  345. (define dylan:concatenate-as
  346.   (dylan::generic-fn 'concatenate-as
  347.     (make-param-list `((CLASS ,<class>) (SEQUENCE ,<sequence>)) #F 'REST #F)
  348.     (lambda (class seq-1 . rest)
  349.       (if (not (subclass? class <mutable-sequence>))
  350.       (dylan-call dylan:error
  351.               "concatenate-as -- target class not a mutable sequence"
  352.               class seq-1 rest))
  353.       (dylan-call dylan:as
  354.           class (dylan-call dylan:apply
  355.                     dylan:concatenate (cons seq-1 rest))))))
  356.  
  357. (define dylan:concatenate
  358.   (dylan::generic-fn 'concatenate
  359.     at-least-one-sequence
  360.     (lambda (seq-1 . rest)
  361.       (dylan-call dylan:error
  362.           "concatenate -- not specialized for argument" seq-1 rest))))
  363.  
  364. (define dylan:replace-subsequence!
  365.   (dylan::generic-fn
  366.    'replace-subsequence!
  367.    (make-param-list `((MUTABLE-SEQUENCE ,<mutable-sequence>)
  368.               (INSERT-SEQUENCE ,<sequence>))
  369.             #F #F '(start:))
  370.    #F))
  371.  
  372. (add-method
  373.  dylan:replace-subsequence!
  374.  (dylan::dylan-callable->method
  375.   (make-param-list `((MUTABLE-SEQUENCE ,<mutable-sequence>)
  376.              (INSERT-SEQUENCE ,<sequence>))
  377.            #F #F '(start:))
  378.   (lambda (multiple-values next-method mutable insert . rest)
  379.     multiple-values
  380.     (dylan::keyword-validate next-method rest '(start:))
  381.     (let ((start (dylan::find-keyword rest 'start: (lambda () 0)))
  382.       (m-state (dylan-call dylan:initial-state mutable)))
  383.       (if (< (- (dylan-call dylan:size mutable) start)
  384.          (dylan-call dylan:size insert))
  385.       (dylan-call dylan:error
  386.               "replace-subsequence! -- not enough elements in target"
  387.               mutable insert start))
  388.       (if (negative? start)
  389.       (dylan-call dylan:error
  390.               "replace-subsequence! -- index cannot be negative"
  391.               mutable insert start))
  392.       (do ((count 0 (+ count 1)))
  393.       ((= count start) 'done)
  394.     (set! m-state (dylan-call dylan:next-state mutable m-state)))
  395.       (let loop ((i-state (dylan-call dylan:initial-state insert))
  396.          (m-state m-state))
  397.     (if i-state
  398.         (begin
  399.           (dylan-call
  400.            dylan:setter/current-element/
  401.            mutable m-state
  402.            (dylan-call dylan:current-element insert i-state))
  403.           (loop (dylan-call dylan:next-state insert i-state)
  404.             (dylan-call dylan:next-state mutable m-state)))
  405.         mutable))))))
  406.  
  407.  
  408. (define dylan:reverse
  409.   (dylan::generic-fn 'reverse
  410.     one-sequence
  411.     (lambda (seq-1)
  412.       (dylan-call dylan:error
  413.           "reverse -- not defined for this sequence type" seq-1))))
  414.  
  415.  
  416. (define dylan:reverse!
  417.   (dylan::generic-fn 'reverse!
  418.     one-sequence
  419.     (lambda (seq-1)
  420.       (dylan-call dylan:reverse seq-1))))
  421.  
  422.  
  423. (define dylan:sort
  424.   (dylan::generic-fn
  425.    'sort
  426.    (make-param-list `((SEQUENCE ,<sequence>)) #F #F '(test: stable:))
  427.    #F))
  428.  
  429. (add-method
  430.  dylan:sort
  431.  (dylan::dylan-callable->method
  432.   (make-param-list `((SEQUENCE ,<sequence>)) #F #F '(test: stable:))
  433.   (lambda (multiple-values next-method seq . rest)
  434.     multiple-values
  435.     (dylan::keyword-validate next-method rest '(test: stable:))
  436.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:<)))
  437.       (stable (dylan::find-keyword rest 'stable: (lambda () #F))))
  438.       stable            ; Ignored
  439.       (dylan-call dylan:as
  440.           (dylan-call dylan:class-for-copy seq)
  441.           (sort (dylan-call dylan:as <list> seq)
  442.             (lambda (x y)
  443.               (dylan-call test? x y))))))))
  444.  
  445. (define dylan:sort!
  446.   (dylan::generic-fn
  447.    'sort!
  448.    (make-param-list `((SEQUENCE ,<sequence>)) #F #F '(test: stable:))
  449.    #F))
  450.  
  451. (add-method
  452.  dylan:sort!
  453.  (dylan::dylan-callable->method
  454.   (make-param-list `((SEQUENCE ,<sequence>)) #F #F '(test: stable:))
  455.   (lambda (multiple-values next-method seq . rest)
  456.     multiple-values
  457.     (dylan::keyword-validate next-method rest '(test: stable:))
  458.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:<)))
  459.       (stable (dylan::find-keyword rest 'stable: (lambda () #F))))
  460.       (dylan-call dylan:sort seq 'test: test? 'stable: stable)))))
  461.  
  462. (define dylan:first
  463.   (dylan::generic-fn 'first
  464.     one-sequence
  465.     (lambda (sequence-1)
  466.       (let ((state (dylan-call dylan:initial-state sequence-1)))
  467.     (if state
  468.         (dylan-call dylan:current-element sequence-1 state)
  469.         (dylan-call dylan:error
  470.             "first -- no element in sequence" sequence-1))))))
  471.  
  472. (define dylan:second
  473.   (dylan::generic-fn 'second
  474.     one-sequence
  475.     (lambda (sequence-1)
  476.       (let ((state (dylan-call dylan:get-state sequence-1 1)))
  477.     (if state
  478.         (dylan-call dylan:current-element sequence-1 state)
  479.         (dylan-call dylan:error
  480.             "second -- sequence size < 2" sequence-1))))))
  481.  
  482. (define dylan:third
  483.   (dylan::generic-fn 'third
  484.     one-sequence
  485.     (lambda (sequence-1)
  486.       (let ((state (dylan-call dylan:get-state sequence-1 2)))
  487.     (if state
  488.         (dylan-call dylan:current-element sequence-1 state)
  489.         (dylan-call dylan:error
  490.             "third -- sequence size < 3" sequence-1))))))
  491.  
  492.  
  493. (define dylan:setter/first/
  494.   (dylan::generic-fn 'setter/first/
  495.     one-mutable-sequence-and-an-object
  496.     (lambda (sequence-1 new-value)
  497.       (let ((state (dylan-call dylan:initial-state sequence-1)))
  498.     (if state
  499.         (begin
  500.           (dylan-call
  501.            dylan:setter/current-element/ sequence-1 state new-value)
  502.           new-value)
  503.         (dylan-call dylan:error
  504.             "(setter first) -- sequence is empty"
  505.             sequence-1 new-value))))))
  506.  
  507. (define dylan:setter/second/
  508.   (dylan::generic-fn 'setter/first/
  509.     one-mutable-sequence-and-an-object
  510.     (lambda (sequence-1 new-value)
  511.       (let ((size (dylan-call dylan:size sequence-1)))
  512.     (if (or (not size) (>= size 2))
  513.         (begin
  514.           (dylan-call dylan:setter/current-element/
  515.               sequence-1
  516.               (dylan-call dylan:get-state sequence-1 1)
  517.               new-value)
  518.           new-value)
  519.         (dylan-call dylan:error
  520.             "(setter second) -- sequence size < 2"
  521.             sequence-1 new-value))))))
  522.  
  523. (define dylan:setter/third/
  524.   (dylan::generic-fn 'setter/first/
  525.     one-mutable-sequence-and-an-object
  526.     (lambda (sequence-1 new-value)
  527.       (let ((size (dylan-call dylan:size sequence-1)))
  528.     (if (or (not size) (>= size 3))
  529.         (begin
  530.           (dylan-call dylan:setter/current-element/
  531.               sequence-1
  532.               (dylan-call dylan:get-state sequence-1 2)
  533.               new-value)
  534.           new-value)
  535.         (dylan-call dylan:error
  536.             "(setter third) -- sequence size < 3"
  537.             sequence-1 new-value))))))
  538.  
  539. (define dylan:last
  540.   (dylan::generic-fn 'last
  541.     one-sequence
  542.     (lambda (sequence-1)
  543.       (let ((prev-state #F))
  544.     (do ((state (dylan-call dylan:initial-state sequence-1)
  545.             (dylan-call dylan:next-state sequence-1 state)))
  546.         ((not state)
  547.          (if prev-state
  548.          (dylan-call dylan:current-element sequence-1 prev-state)
  549.          (dylan-call dylan:error
  550.                  "last -- sequence is empty" sequence-1)))
  551.       (set! prev-state state))))))
  552.  
  553. (define (check-subsequence test? big big-state pattern pattern-state)
  554.   (define (check-loop big-state pattern-state)
  555.     (if (not pattern-state)
  556.     #T
  557.     (if (and big-state
  558.          (dylan-call test?
  559.                  (dylan-call dylan:current-element big big-state)
  560.           (dylan-call dylan:current-element pattern pattern-state)))
  561.         (check-loop
  562.          (dylan-call dylan:next-state big big-state)
  563.          (dylan-call dylan:next-state pattern pattern-state))
  564.         #F)))
  565.   (check-loop (dylan-call dylan:copy-state big big-state)
  566.           (dylan-call dylan:copy-state pattern pattern-state)))
  567.  
  568. (define dylan:subsequence-position
  569.   (dylan::generic-fn
  570.    'subsequence-position
  571.    (make-param-list
  572.     `((BIG ,<sequence>) (PATTERN ,<sequence>)) #F #F '(test: count:))
  573.    #F))
  574.  
  575. (add-method
  576.  dylan:subsequence-position
  577.  (dylan::dylan-callable->method
  578.   (make-param-list
  579.    `((BIG ,<sequence>) (PATTERN ,<sequence>)) #F #F '(test: count:))
  580.   (lambda (multiple-values next-method big pattern . rest)
  581.     multiple-values
  582.     (dylan::keyword-validate next-method rest '(test: count:))
  583.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?)))
  584.       (count (dylan::find-keyword rest 'count: (lambda () 1)))
  585.       (first-of-pattern (dylan-call dylan:first pattern))
  586.       (init-state-pattern (dylan-call dylan:initial-state pattern)))
  587.       (let loop ((state (dylan-call dylan:initial-state big))
  588.          (num-found 0)
  589.          (index 0))
  590.     (if state
  591.         (if (and (dylan-call test?
  592.                  (dylan-call dylan:current-element big state)
  593.                  first-of-pattern)
  594.              (check-subsequence test? big state
  595.                     pattern init-state-pattern))
  596.         (if (>= num-found (- count 1))
  597.             index
  598.             (loop (dylan-call dylan:next-state big state)
  599.               (+ num-found 1)
  600.               (+ index 1)))
  601.         (loop (dylan-call dylan:next-state big state)
  602.               num-found
  603.               (+ index 1)))
  604.         #F))))))            ; not found
  605.  
  606. ;;;;
  607. ;;;; MUTABLE COLLECTIONS (p. 127)
  608. ;;;;
  609.  
  610. (define dylan:setter/current-element/
  611.   (dylan::generic-fn 'setter/current-element/
  612.     (make-param-list `((MUTABLE-COLLECTION ,<mutable-collection>)
  613.                (STATE ,<object>)
  614.                (NEW-VALUE ,<object>))
  615.              #F #F #F)
  616.     (lambda (mutable-collection state new-value)
  617.       (dylan-call dylan:error
  618.           "(setter current-element) -- cannot set! this collection type"
  619.           mutable-collection state new-value))))
  620.  
  621. (define dylan:setter/element/
  622.   (dylan::generic-fn 'setter/element/
  623.     (make-param-list `((MUTABLE-COLLECTION ,<mutable-collection>)
  624.                (KEY ,<object>)
  625.                (NEW-VAL ,<object>))
  626.              #F #F #F)
  627.     (lambda (collection key new-value)
  628.       (dylan-call dylan:error
  629.           "(setter element) -- not defined for this collection type"
  630.           collection key new-value))))
  631.  
  632. (add-method dylan:setter/element/
  633.   (dylan::function->method
  634.    (make-param-list `((MUTABLE-SEQUENCE ,<mutable-sequence>)
  635.               (KEY ,<integer>)
  636.               (NEW-VALUE ,<object>))
  637.             #F #F #F)
  638.    (lambda (mut-seq key new-value)
  639.      (do ((state (dylan-call dylan:initial-state mut-seq)
  640.          (dylan-call dylan:next-state mut-seq state))
  641.       (k 0 (+ k 1)))
  642.      ((or (not state) (= k key))
  643.       (if state
  644.           (begin
  645.         (dylan-call dylan:setter/current-element/
  646.                 mut-seq state new-value)
  647.         new-value)
  648.           (dylan-call dylan:error
  649.               "(setter element) -- key not found"
  650.               mut-seq key new-value)))))))
  651.  
  652. (add-method dylan:setter/element/
  653.   (dylan::function->method
  654.    (make-param-list
  655.     `((MUTABLE-EXPLICIT-KEY-COLLECTION ,<mutable-explicit-key-collection>)
  656.       (KEY ,<object>)
  657.       (NEW-VALUE ,<object>))
  658.     #F #F #F)
  659.    (lambda (mut-seq key new-value)
  660.      (do ((state (dylan-call dylan:initial-state mut-seq)
  661.          (dylan-call dylan:next-state mut-seq state)))
  662.      ((or (not state) (dylan-call
  663.                dylan:=
  664.                (dylan-call dylan:current-key mut-seq state)
  665.                key))
  666.       (if state
  667.           (begin
  668.         (dylan-call dylan:setter/current-element/
  669.                 mut-seq state new-value)
  670.         new-value)
  671.           (dylan-call dylan:error
  672.               "(setter element) -- key not found"
  673.               mut-seq key new-value)))))))
  674.