home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / run-collections-vector.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  15.7 KB  |  444 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-vector.scm,v 1.13 1992/08/31 05:35:35 birkholz Exp $
  39.  
  40. ;;;;; This file contains all the specializations for vector,
  41. ;;;;; simple-object-vector, and stretchy-vector types
  42.  
  43. (add-method dylan:shallow-copy        ; To override <array> handling
  44.   (dylan::function->method
  45.     (make-param-list `((vector ,<vector>)) #F #F #F)
  46.     (lambda (seq)
  47.       (dylan-call dylan:copy-sequence seq))))
  48.  
  49. (add-method dylan:as
  50.   (dylan::function->method
  51.    (make-param-list `((CLASS ,(dylan::make-singleton <vector>))
  52.               (COLLECTION ,<collection>)) #F #F #F)
  53.    (lambda (class collection)
  54.      class                ; Ignored
  55.      (if (dylan-call dylan:instance? collection <vector>)
  56.      collection
  57.      (dylan-call dylan:as <simple-object-vector> collection)))))
  58.  
  59. (add-method dylan:as
  60.   (dylan::function->method
  61.    (make-param-list `((CLASS ,(dylan::make-singleton <simple-object-vector>))
  62.               (COLLECTION ,<collection>)) #F #F #F)
  63.    (lambda (class collection)
  64.      class                ; Ignored
  65.      (if (dylan-call dylan:instance? collection <simple-object-vector>)
  66.      collection
  67.      (let* ((size (dylan-call dylan:size collection))
  68.         (new-vector (make-vector size)))
  69.        (do ((state (dylan-call dylan:initial-state collection)
  70.                (dylan-call dylan:next-state collection state))
  71.         (index 0 (+ index 1)))
  72.            ((not state) new-vector)
  73.          (vector-set!
  74.           new-vector index
  75.           (dylan-call dylan:current-element collection state))))))))
  76.  
  77. (add-method dylan:as
  78.   (dylan::function->method
  79.    (make-param-list `((CLASS ,(dylan::make-singleton <stretchy-vector>))
  80.               (COLLECTION ,<collection>)) #F #F #F)
  81.    (lambda (class collection)
  82.      class                ; Ignored
  83.      (if (dylan-call dylan:instance? collection <stretchy-vector>)
  84.      collection
  85.      (let* ((size (dylan-call dylan:size collection))
  86.         (new-s-vector
  87.          (dylan-call dylan:make <stretchy-vector> 'size: size))
  88.         (vector-value (dylan-call dylan:get-array-value new-s-vector)))
  89.        (do ((state (dylan-call dylan:initial-state collection)
  90.                (dylan-call dylan:next-state collection state))
  91.         (index 0 (+ index 1)))
  92.            ((not state) new-s-vector)
  93.          (vector-set!
  94.           vector-value index
  95.           (dylan-call dylan:current-element collection state))))))))
  96.  
  97. ;;;
  98. ;;; VECTOR SPECIALIZED MAKE
  99. ;;; <vector> ... like the book says, this yields a
  100. ;;; <simple-object-vector>
  101. ;;;
  102. (add-method dylan:make
  103.   (dylan::function->method
  104.    (make-param-list `((VECTOR ,(dylan::make-singleton <vector>)))
  105.             #F #F #T)
  106.    (lambda (class . rest)
  107.      class                ; Ignored
  108.      (dylan-apply dylan:make <simple-object-vector> rest))))
  109.  
  110.  
  111.  
  112. ;;;
  113. ;;; SIMPLE-OBJECT-VECTOR SPECIALIZED MAKE
  114. ;;; <simple-object-vector> generates a Scheme vector
  115. ;;;
  116. (add-method
  117.  dylan:make
  118.  (dylan::dylan-callable->method
  119.   (make-param-list `((SOV ,(dylan::make-singleton
  120.                 <simple-object-vector>)))
  121.            #F #F '(size: fill:))
  122.   (lambda (multiple-values next-method class . rest)
  123.     multiple-values class        ; Not used
  124.     (dylan::keyword-validate next-method rest '(size: fill:))
  125.     (let* ((size (dylan::find-keyword rest 'size: (lambda () 0)))
  126.        (fill (dylan::find-keyword rest 'fill: (lambda () #F))))
  127.       (if (or (not (integer? size)) (negative? size))
  128.       (dylan-call
  129.        dylan:error
  130.        "(make (singleton <simple-object-vector>)) -- size: invalid" size))
  131.       (make-vector size fill)))))
  132.  
  133.  
  134.  
  135. ;;;
  136. ;;; STRETCHY-VECTOR SPECIALIZED MAKE
  137. ;;; <stretchy-vector> has one slot, for the vector itself.  I'm using
  138. ;;; the slot that is inherited from <array> for this purpose.
  139. ;;; Dimensions here is a list of one number.
  140. ;;;
  141. (add-method
  142.  dylan:make
  143.  (dylan::dylan-callable->method
  144.   (make-param-list `((SV ,(dylan::make-singleton <stretchy-vector>)))
  145.            #F #F '(size: fill:))
  146.   (lambda (multiple-values next-method class . rest)
  147.     multiple-values class        ; Not used
  148.     (dylan::keyword-validate next-method rest '(size: fill:))
  149.     (let* ((size (dylan::find-keyword rest 'size: (lambda () 0)))
  150.        (fill (dylan::find-keyword rest 'fill: (lambda () #F))))
  151.       (if (or (not (integer? size)) (negative? size))
  152.       (dylan-call dylan:error
  153.               "(make (singleton <stretchy-vector>)) size: invalid"
  154.               size))
  155.       (let ((instance (dylan::make-<object> <stretchy-vector>)))
  156.     (dylan-call dylan:set-array-value!
  157.             instance (make-vector size fill))
  158.     (dylan-call dylan:set-array-dimensions! instance (list size))
  159.     instance)))))
  160.  
  161. ;;;
  162. ;;; Functions for collections
  163. ;;;
  164. (add-method dylan:size
  165.   (one-arg 'SOV <vector>
  166.     (lambda (vect) (vector-length (dylan-call dylan:get-array-value vect)))))
  167.  
  168. ;;;
  169. ;;; Functions for sequences
  170. ;;;
  171. (add-method dylan:add
  172.  (dylan::function->method one-vector-and-an-object
  173.    (lambda (vector new-element)
  174.      (let ((new-vector (dylan-call dylan:make <vector>))
  175.        (size (car (dylan-call dylan:get-array-dimensions vector))))
  176.        (dylan-call dylan:set-array-value!
  177.            new-vector
  178.            (list->vector (cons new-element (vector->list vector))))
  179.        (dylan-call dylan:set-array-dimensions! new-vector (list (+ size 1)))
  180.        new-vector))))
  181.  
  182. (add-method dylan:add
  183.   (dylan::function->method one-simple-object-vector-and-an-object
  184.     (lambda (sov new-element)
  185.       (list->vector (cons new-element (vector->list sov))))))
  186.  
  187. (add-method dylan:add
  188.   (dylan::function->method one-stretchy-vector-and-an-object
  189.     (lambda (s-vector new-element)
  190.       (let ((new-vector (dylan-call dylan:make <stretchy-vector>))
  191.         (size (car (dylan-call dylan:get-array-dimensions s-vector))))
  192.     (dylan-call dylan:set-array-value!
  193.             new-vector
  194.             (list->vector (cons new-element (vector->list s-vector))))
  195.     (dylan-call dylan:set-array-dimensions!
  196.             new-vector (list (+ size 1)))
  197.     new-vector))))
  198.  
  199. (add-method dylan:add!
  200.   (dylan::function->method
  201.    one-stretchy-vector-and-an-object
  202.    (lambda (s-vector new-element)
  203.      (let* ((vector (dylan-call dylan:get-array-value s-vector))
  204.         (size (car (dylan-call dylan:get-array-dimensions s-vector)))
  205.         (new-vector (make-vector (+ size 1))))
  206.        (do ((count 0 (+ count 1)))
  207.        ((= count size) 'done)
  208.      (vector-set! new-vector count (vector-ref vector count)))
  209.        (vector-set! new-vector size new-element)
  210.        (dylan-call dylan:set-array-value! s-vector new-vector)
  211.        (dylan-call dylan:set-array-dimensions! s-vector (list (+ size 1)))
  212.        s-vector))))
  213.  
  214. (add-method dylan:concatenate
  215.   (dylan::function->method
  216.    (make-param-list `((SOV ,<simple-object-vector>)) #F 'REST #F)
  217.    (lambda (vector-1 . rest)
  218.      (let loop ((result (vector->list vector-1))
  219.         (rest-vectors (map (lambda (seq)
  220.                      (dylan-call dylan:as
  221.                          <simple-object-vector> seq))
  222.                    rest)))
  223.        (if (null? rest-vectors)
  224.        (list->vector result)
  225.        (loop (append result (vector->list (car rest-vectors)))
  226.          (cdr rest-vectors)))))))
  227.  
  228. (add-method dylan:concatenate
  229.   (dylan::function->method
  230.    (make-param-list `((VECTOR ,<vector>)) #F 'REST #F)
  231.    (lambda (vector-1 . rest)
  232.      (dylan-call dylan:apply dylan:concatenate vector-1 rest))))
  233.  
  234.  
  235. (add-method
  236.  dylan:remove!
  237.  (dylan::dylan-callable->method
  238.   (make-param-list `((STRETCHY-VECTOR ,<stretchy-vector>) (VALUE ,<object>))
  239.            #F #F '(test: count:))
  240.   (lambda (multiple-values next-method s-vector value . rest)
  241.     multiple-values
  242.     (dylan::keyword-validate next-method rest '(test: count:))
  243.     (let* ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?)))
  244.        (count (dylan::find-keyword
  245.            rest 'count:
  246.            (lambda ()
  247.              (car (dylan-call dylan:get-array-dimensions s-vector)))))
  248.        (old-vector (dylan-call dylan:get-array-value s-vector))
  249.        (new-vector (dylan-call dylan:remove
  250.                    old-vector value
  251.                    'test: test? 'count: count)))
  252.       (dylan-call dylan:set-array-value! s-vector new-vector)
  253.       (dylan-call dylan:set-array-dimensions!
  254.           s-vector (list (vector-length new-vector)))
  255.       s-vector))))
  256.  
  257.  
  258. (add-method
  259.  dylan:remove-duplicates!
  260.  (dylan::dylan-callable->method
  261.   (make-param-list `((STRETCHY-VECTOR ,<stretchy-vector>)) #F #F '(test:))
  262.   (lambda (multiple-values next-method s-vector . rest)
  263.     multiple-values
  264.     (dylan::keyword-validate next-method rest '(test:))
  265.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?))))
  266.       (let ((new-vector (dylan-call dylan:remove-duplicates
  267.                     (dylan-call dylan:get-array-value
  268.                         s-vector)
  269.                     'test: test?)))
  270.     (dylan-call dylan:set-array-value! s-vector new-vector)
  271.     (dylan-call dylan:set-array-dimensions!
  272.             s-vector (list (vector-length new-vector)))
  273.     s-vector)))))
  274.  
  275. (add-method dylan:reverse
  276.   (dylan::function->method one-simple-object-vector
  277.     (lambda (vector-1)
  278.       (let ((result (make-vector (vector-length vector-1))))
  279.     (do ((from (- (vector-length vector-1) 1) (- from 1))
  280.          (to 0 (+ to 1)))
  281.         ((< from 0) result)
  282.       (vector-set! result to (vector-ref vector-1 from)))
  283.     result))))
  284.  
  285.  
  286. (add-method dylan:reverse
  287.   (dylan::function->method one-stretchy-vector
  288.     (lambda (s-vector)
  289.       (let* ((vector-1 (dylan-call dylan:get-array-value s-vector))
  290.          (result (make-vector (vector-length vector-1)))
  291.          (result-s-vector (dylan-call dylan:make <stretchy-vector>)))
  292.     (do ((from (- (vector-length vector-1) 1) (- from 1))
  293.          (to 0 (+ to 1)))
  294.         ((< from 0) result)
  295.       (vector-set! result to (vector-ref vector-1 from)))
  296.     (dylan-call dylan:set-array-value! result-s-vector result)
  297.     (dylan-call dylan:set-array-dimensions!
  298.             result-s-vector (list (vector-length result)))
  299.     result-s-vector))))
  300.  
  301. (add-method dylan:reverse!
  302.   (dylan::function->method one-simple-object-vector
  303.     (lambda (vector-1)
  304.       (do ((from (- (vector-length vector-1) 1) (- from 1))
  305.        (to 0 (+ to 1)))
  306.       ((<= from to) vector-1)
  307.     (let ((to-element (vector-ref vector-1 to)))
  308.       (vector-set! vector-1 to (vector-ref vector-1 from))
  309.       (vector-set! vector-1 from to-element))))))
  310.  
  311.  
  312. (add-method dylan:reverse!
  313.   (dylan::function->method one-stretchy-vector
  314.     (lambda (s-vector)
  315.       (let ((vector-1 (dylan-call dylan:get-array-value s-vector)))
  316.     (do ((from (- (vector-length vector-1) 1) (- from 1))
  317.          (to 0 (+ to 1)))
  318.         ((<= from to) s-vector)
  319.       (let ((to-element (vector-ref vector-1 to)))
  320.         (vector-set! vector-1 to (vector-ref vector-1 from))
  321.         (vector-set! vector-1 from to-element)))))))
  322.  
  323.  
  324. (add-method
  325.  dylan:sort!
  326.  (dylan::dylan-callable->method
  327.   (make-param-list `((STRETCHY-VECTOR ,<stretchy-vector>))
  328.            #F #F '(test: stable:))
  329.   (lambda (multiple-values next-method s-vector . rest)
  330.     multiple-values
  331.     (dylan::keyword-validate next-method rest '(test: stable:))
  332.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:<)))
  333.       (stable (dylan::find-keyword rest 'stable: (lambda () #F))))
  334.       stable                ; Ignored
  335.       (dylan-call dylan:set-array-value!
  336.           s-vector
  337.           (dylan-call dylan:as
  338.                   <simple-object-vector>
  339.                   (sort (dylan-call dylan:as <pair> s-vector)
  340.                     (lambda (x y)
  341.                       (dylan-call test? x y)))))))))
  342.  
  343. (add-method dylan:first
  344.   (dylan::function->method one-vector
  345.     (lambda (vector)
  346.       (if (= (vector-length vector) 0)
  347.       (dylan-call dylan:error "(first <vector>) -- vector is empty" vector)
  348.       (vector-ref vector 0)))))
  349.  
  350. (add-method dylan:second
  351.   (dylan::function->method one-vector
  352.     (lambda (vector)
  353.       (if (< (vector-length vector) 2)
  354.       (dylan-call dylan:error
  355.               "(second <vector>) -- vector doesn't have 2 elements"
  356.               vector)
  357.       (vector-ref vector 1)))))
  358.  
  359. (add-method dylan:third
  360.   (dylan::function->method one-vector
  361.     (lambda (vector)
  362.       (if (< (vector-length vector) 3 )
  363.       (dylan-call dylan:error
  364.               "(third <vector>) -- vector doesn't have 3 elements"
  365.               vector)
  366.       (vector-ref vector 2)))))
  367.  
  368. (add-method dylan:last
  369.   (dylan::function->method one-vector
  370.     (lambda (vector)
  371.       (let* ((vector-value (dylan-call dylan:get-array-value vector))
  372.          (vl (vector-length vector-value)))
  373.     (if (zero? vl)
  374.         (dylan-call dylan:error "(last <vector>) -- vector is empty" vector)
  375.         (vector-ref vector-value (- vl 1)))))))
  376.  
  377. (define dylan:vector
  378.   (dylan::function->method
  379.     (make-param-list '() #F 'REST-ARGS #F)
  380.     (lambda args
  381.       (if (null? args)
  382.       (vector)
  383.       (apply vector args)))))
  384.  
  385. (add-method dylan:current-key
  386.   (dylan::function->method
  387.    (make-param-list `((VECTOR ,<vector>) (STATE ,<object>)) #F #F #F)
  388.    (lambda (vector state)
  389.      vector                ; Ignored
  390.      (vector-ref state 0))))
  391.  
  392. ;;;
  393. ;;; Collection Keys
  394. ;;;
  395.  
  396. (add-method
  397.  dylan:element
  398.  (dylan::dylan-callable->method
  399.   (make-param-list `((VECTOR ,<vector>) (INDEX ,<integer>)) #F #F '(default:))
  400.   (lambda (multiple-values next-method vector index . rest)
  401.     multiple-values
  402.     (dylan::keyword-validate next-method rest '(default:))
  403.     (let ((vector-value (dylan-call dylan:get-array-value vector)))
  404.       (let ((size (vector-length vector-value)))
  405.     (if (and (>= index 0) (< index size))
  406.         (vector-ref vector-value index)
  407.         (dylan::find-keyword
  408.          rest '(default:)
  409.          (lambda ()
  410.            (dylan-call dylan:error "(element <vector> <integer>) -- invalid index with no default value" vector-value index)))))))))
  411.  
  412. ;;;
  413. ;;; Mutable Collections
  414. ;;;
  415.  
  416. (add-method dylan:setter/current-element/
  417.   (dylan::function->method
  418.     (make-param-list
  419.      `((SOV ,<simple-object-vector>) (STATE ,<object>) (new-value ,<object>))
  420.        #F #F #F)
  421.     (lambda (sov state new-value)
  422.       (vector-set! sov (vector-ref state 0) new-value)
  423.       new-value)))
  424.  
  425. (add-method dylan:setter/current-element/
  426.   (dylan::function->method
  427.     (make-param-list `((STRETCHY-VECTOR ,<stretchy-vector>)
  428.                (STATE ,<object>)
  429.                (new-value ,<object>))
  430.      #F #F #F)
  431.     (lambda (st-vector state new-value)
  432.       (vector-set! (dylan-call dylan:get-array-value st-vector)
  433.            (vector-ref state 0) new-value)
  434.       new-value)))
  435.  
  436. (add-method dylan:setter/element/
  437.   (dylan::function->method
  438.     (make-param-list
  439.      `((VECTOR ,<vector>) (INDEX ,<object>) (NEW-VALUE ,<object>)) #F #F #F)
  440.     (lambda (vector-instance index new-value)
  441.       (let ((vector (dylan-call dylan:get-array-value vector-instance)))
  442.     (vector-set! vector index new-value)
  443.     new-value))))
  444.