home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Thomas / run-collections-vector.scm < prev    next >
Encoding:
Text File  |  1992-11-25  |  15.7 KB  |  435 lines  |  [TEXT/gamI]
  1. tware agree to the terms and conditions set forth herein,
  2. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  3. ;* right and license under any changes, enhancements or extensions made to the
  4. ;* core functions of the software, including but not limited to those affording
  5. ;* compatibility with other hardware or software environments, but excluding
  6. ;* applications which incorporate this software.  Users further agree to use
  7. ;* their best efforts to return to Digital any such changes, enhancements or
  8. ;* extensions that they make and inform Digital of noteworthy uses of this
  9. ;* software.  Correspondence should be provided to Digital at:
  10. ;* 
  11. ;*            Director, Cambridge Research Lab
  12. ;*            Digital Equipment Corp
  13. ;*            One Kendall Square, Bldg 700
  14. ;*            Cambridge MA 02139
  15. ;* 
  16. ;* This software may be distributed (but not offered for sale or transferred
  17. ;* for compensation) to third parties, provided such third parties agree to
  18. ;* abide by the terms and conditions of this notice.
  19. ;* 
  20. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  21. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  22. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  23. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  24. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  25. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  26. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  27. ;* SOFTWARE.
  28.  
  29. ; $Id: runtime-collections-vector.scm,v 1.13 1992/08/31 05:35:35 birkholz Exp $
  30.  
  31. ;;;;; This file contains all the specializations for vector,
  32. ;;;;; simple-object-vector, and stretchy-vector types
  33.  
  34. (add-method dylan:shallow-copy        ; To override <array> handling
  35.   (dylan::function->method
  36.     (make-param-list `((vector ,<vector>)) #F #F #F)
  37.     (lambda (seq)
  38.       (dylan-call dylan:copy-sequence seq))))
  39.  
  40. (add-method dylan:as
  41.   (dylan::function->method
  42.    (make-param-list `((CLASS ,(dylan::make-singleton <vector>))
  43.               (COLLECTION ,<collection>)) #F #F #F)
  44.    (lambda (class collection)
  45.      class                ; Ignored
  46.      (if (dylan-call dylan:instance? collection <vector>)
  47.      collection
  48.      (dylan-call dylan:as <simple-object-vector> collection)))))
  49.  
  50. (add-method dylan:as
  51.   (dylan::function->method
  52.    (make-param-list `((CLASS ,(dylan::make-singleton <simple-object-vector>))
  53.               (COLLECTION ,<collection>)) #F #F #F)
  54.    (lambda (class collection)
  55.      class                ; Ignored
  56.      (if (dylan-call dylan:instance? collection <simple-object-vector>)
  57.      collection
  58.      (let* ((size (dylan-call dylan:size collection))
  59.         (new-vector (make-vector size)))
  60.        (do ((state (dylan-call dylan:initial-state collection)
  61.                (dylan-call dylan:next-state collection state))
  62.         (index 0 (+ index 1)))
  63.            ((not state) new-vector)
  64.          (vector-set!
  65.           new-vector index
  66.           (dylan-call dylan:current-element collection state))))))))
  67.  
  68. (add-method dylan:as
  69.   (dylan::function->method
  70.    (make-param-list `((CLASS ,(dylan::make-singleton <stretchy-vector>))
  71.               (COLLECTION ,<collection>)) #F #F #F)
  72.    (lambda (class collection)
  73.      class                ; Ignored
  74.      (if (dylan-call dylan:instance? collection <stretchy-vector>)
  75.      collection
  76.      (let* ((size (dylan-call dylan:size collection))
  77.         (new-s-vector
  78.          (dylan-call dylan:make <stretchy-vector> 'size: size))
  79.         (vector-value (dylan-call dylan:get-array-value new-s-vector)))
  80.        (do ((state (dylan-call dylan:initial-state collection)
  81.                (dylan-call dylan:next-state collection state))
  82.         (index 0 (+ index 1)))
  83.            ((not state) new-s-vector)
  84.          (vector-set!
  85.           vector-value index
  86.           (dylan-call dylan:current-element collection state))))))))
  87.  
  88. ;;;
  89. ;;; VECTOR SPECIALIZED MAKE
  90. ;;; <vector> ... like the book says, this yields a
  91. ;;; <simple-object-vector>
  92. ;;;
  93. (add-method dylan:make
  94.   (dylan::function->method
  95.    (make-param-list `((VECTOR ,(dylan::make-singleton <vector>)))
  96.             #F #F #T)
  97.    (lambda (class . rest)
  98.      class                ; Ignored
  99.      (dylan-apply dylan:make <simple-object-vector> rest))))
  100.  
  101.  
  102.  
  103. ;;;
  104. ;;; SIMPLE-OBJECT-VECTOR SPECIALIZED MAKE
  105. ;;; <simple-object-vector> generates a Scheme vector
  106. ;;;
  107. (add-method
  108.  dylan:make
  109.  (dylan::dylan-callable->method
  110.   (make-param-list `((SOV ,(dylan::make-singleton
  111.                 <simple-object-vector>)))
  112.            #F #F '(size: fill:))
  113.   (lambda (multiple-values next-method class . rest)
  114.     multiple-values class        ; Not used
  115.     (dylan::keyword-validate next-method rest '(size: fill:))
  116.     (let* ((size (dylan::find-keyword rest 'size: (lambda () 0)))
  117.        (fill (dylan::find-keyword rest 'fill: (lambda () #F))))
  118.       (if (or (not (integer? size)) (negative? size))
  119.       (dylan-call
  120.        dylan:error
  121.        "(make (singleton <simple-object-vector>)) -- size: invalid" size))
  122.       (make-vector size fill)))))
  123.  
  124.  
  125.  
  126. ;;;
  127. ;;; STRETCHY-VECTOR SPECIALIZED MAKE
  128. ;;; <stretchy-vector> has one slot, for the vector itself.  I'm using
  129. ;;; the slot that is inherited from <array> for this purpose.
  130. ;;; Dimensions here is a list of one number.
  131. ;;;
  132. (add-method
  133.  dylan:make
  134.  (dylan::dylan-callable->method
  135.   (make-param-list `((SV ,(dylan::make-singleton <stretchy-vector>)))
  136.            #F #F '(size: fill:))
  137.   (lambda (multiple-values next-method class . rest)
  138.     multiple-values class        ; Not used
  139.     (dylan::keyword-validate next-method rest '(size: fill:))
  140.     (let* ((size (dylan::find-keyword rest 'size: (lambda () 0)))
  141.        (fill (dylan::find-keyword rest 'fill: (lambda () #F))))
  142.       (if (or (not (integer? size)) (negative? size))
  143.       (dylan-call dylan:error
  144.               "(make (singleton <stretchy-vector>)) size: invalid"
  145.               size))
  146.       (let ((instance (dylan::make-<object> <stretchy-vector>)))
  147.     (dylan-call dylan:set-array-value!
  148.             instance (make-vector size fill))
  149.     (dylan-call dylan:set-array-dimensions! instance (list size))
  150.     instance)))))
  151.  
  152. ;;;
  153. ;;; Functions for collections
  154. ;;;
  155. (add-method dylan:size
  156.   (one-arg 'SOV <vector>
  157.     (lambda (vect) (vector-length (dylan-call dylan:get-array-value vect)))))
  158.  
  159. ;;;
  160. ;;; Functions for sequences
  161. ;;;
  162. (add-method dylan:add
  163.  (dylan::function->method one-vector-and-an-object
  164.    (lambda (vector new-element)
  165.      (let ((new-vector (dylan-call dylan:make <vector>))
  166.        (size (car (dylan-call dylan:get-array-dimensions vector))))
  167.        (dylan-call dylan:set-array-value!
  168.            new-vector
  169.            (list->vector (cons new-element (vector->list vector))))
  170.        (dylan-call dylan:set-array-dimensions! new-vector (list (+ size 1)))
  171.        new-vector))))
  172.  
  173. (add-method dylan:add
  174.   (dylan::function->method one-simple-object-vector-and-an-object
  175.     (lambda (sov new-element)
  176.       (list->vector (cons new-element (vector->list sov))))))
  177.  
  178. (add-method dylan:add
  179.   (dylan::function->method one-stretchy-vector-and-an-object
  180.     (lambda (s-vector new-element)
  181.       (let ((new-vector (dylan-call dylan:make <stretchy-vector>))
  182.         (size (car (dylan-call dylan:get-array-dimensions s-vector))))
  183.     (dylan-call dylan:set-array-value!
  184.             new-vector
  185.             (list->vector (cons new-element (vector->list s-vector))))
  186.     (dylan-call dylan:set-array-dimensions!
  187.             new-vector (list (+ size 1)))
  188.     new-vector))))
  189.  
  190. (add-method dylan:add!
  191.   (dylan::function->method
  192.    one-stretchy-vector-and-an-object
  193.    (lambda (s-vector new-element)
  194.      (let* ((vector (dylan-call dylan:get-array-value s-vector))
  195.         (size (car (dylan-call dylan:get-array-dimensions s-vector)))
  196.         (new-vector (make-vector (+ size 1))))
  197.        (do ((count 0 (+ count 1)))
  198.        ((= count size) 'done)
  199.      (vector-set! new-vector count (vector-ref vector count)))
  200.        (vector-set! new-vector size new-element)
  201.        (dylan-call dylan:set-array-value! s-vector new-vector)
  202.        (dylan-call dylan:set-array-dimensions! s-vector (list (+ size 1)))
  203.        s-vector))))
  204.  
  205. (add-method dylan:concatenate
  206.   (dylan::function->method
  207.    (make-param-list `((SOV ,<simple-object-vector>)) #F 'REST #F)
  208.    (lambda (vector-1 . rest)
  209.      (let loop ((result (vector->list vector-1))
  210.         (rest-vectors (map (lambda (seq)
  211.                      (dylan-call dylan:as
  212.                          <simple-object-vector> seq))
  213.                    rest)))
  214.        (if (null? rest-vectors)
  215.        (list->vector result)
  216.        (loop (append result (vector->list (car rest-vectors)))
  217.          (cdr rest-vectors)))))))
  218.  
  219. (add-method dylan:concatenate
  220.   (dylan::function->method
  221.    (make-param-list `((VECTOR ,<vector>)) #F 'REST #F)
  222.    (lambda (vector-1 . rest)
  223.      (dylan-call dylan:apply dylan:concatenate vector-1 rest))))
  224.  
  225.  
  226. (add-method
  227.  dylan:remove!
  228.  (dylan::dylan-callable->method
  229.   (make-param-list `((STRETCHY-VECTOR ,<stretchy-vector>) (VALUE ,<object>))
  230.            #F #F '(test: count:))
  231.   (lambda (multiple-values next-method s-vector value . rest)
  232.     multiple-values
  233.     (dylan::keyword-validate next-method rest '(test: count:))
  234.     (let* ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?)))
  235.        (count (dylan::find-keyword
  236.            rest 'count:
  237.            (lambda ()
  238.              (car (dylan-call dylan:get-array-dimensions s-vector)))))
  239.        (old-vector (dylan-call dylan:get-array-value s-vector))
  240.        (new-vector (dylan-call dylan:remove
  241.                    old-vector value
  242.                    'test: test? 'count: count)))
  243.       (dylan-call dylan:set-array-value! s-vector new-vector)
  244.       (dylan-call dylan:set-array-dimensions!
  245.           s-vector (list (vector-length new-vector)))
  246.       s-vector))))
  247.  
  248.  
  249. (add-method
  250.  dylan:remove-duplicates!
  251.  (dylan::dylan-callable->method
  252.   (make-param-list `((STRETCHY-VECTOR ,<stretchy-vector>)) #F #F '(test:))
  253.   (lambda (multiple-values next-method s-vector . rest)
  254.     multiple-values
  255.     (dylan::keyword-validate next-method rest '(test:))
  256.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?))))
  257.       (let ((new-vector (dylan-call dylan:remove-duplicates
  258.                     (dylan-call dylan:get-array-value
  259.                         s-vector)
  260.                     'test: test?)))
  261.     (dylan-call dylan:set-array-value! s-vector new-vector)
  262.     (dylan-call dylan:set-array-dimensions!
  263.             s-vector (list (vector-length new-vector)))
  264.     s-vector)))))
  265.  
  266. (add-method dylan:reverse
  267.   (dylan::function->method one-simple-object-vector
  268.     (lambda (vector-1)
  269.       (let ((result (make-vector (vector-length vector-1))))
  270.     (do ((from (- (vector-length vector-1) 1) (- from 1))
  271.          (to 0 (+ to 1)))
  272.         ((< from 0) result)
  273.       (vector-set! result to (vector-ref vector-1 from)))
  274.     result))))
  275.  
  276.  
  277. (add-method dylan:reverse
  278.   (dylan::function->method one-stretchy-vector
  279.     (lambda (s-vector)
  280.       (let* ((vector-1 (dylan-call dylan:get-array-value s-vector))
  281.          (result (make-vector (vector-length vector-1)))
  282.          (result-s-vector (dylan-call dylan:make <stretchy-vector>)))
  283.     (do ((from (- (vector-length vector-1) 1) (- from 1))
  284.          (to 0 (+ to 1)))
  285.         ((< from 0) result)
  286.       (vector-set! result to (vector-ref vector-1 from)))
  287.     (dylan-call dylan:set-array-value! result-s-vector result)
  288.     (dylan-call dylan:set-array-dimensions!
  289.             result-s-vector (list (vector-length result)))
  290.     result-s-vector))))
  291.  
  292. (add-method dylan:reverse!
  293.   (dylan::function->method one-simple-object-vector
  294.     (lambda (vector-1)
  295.       (do ((from (- (vector-length vector-1) 1) (- from 1))
  296.        (to 0 (+ to 1)))
  297.       ((<= from to) vector-1)
  298.     (let ((to-element (vector-ref vector-1 to)))
  299.       (vector-set! vector-1 to (vector-ref vector-1 from))
  300.       (vector-set! vector-1 from to-element))))))
  301.  
  302.  
  303. (add-method dylan:reverse!
  304.   (dylan::function->method one-stretchy-vector
  305.     (lambda (s-vector)
  306.       (let ((vector-1 (dylan-call dylan:get-array-value s-vector)))
  307.     (do ((from (- (vector-length vector-1) 1) (- from 1))
  308.          (to 0 (+ to 1)))
  309.         ((<= from to) s-vector)
  310.       (let ((to-element (vector-ref vector-1 to)))
  311.         (vector-set! vector-1 to (vector-ref vector-1 from))
  312.         (vector-set! vector-1 from to-element)))))))
  313.  
  314.  
  315. (add-method
  316.  dylan:sort!
  317.  (dylan::dylan-callable->method
  318.   (make-param-list `((STRETCHY-VECTOR ,<stretchy-vector>))
  319.            #F #F '(test: stable:))
  320.   (lambda (multiple-values next-method s-vector . rest)
  321.     multiple-values
  322.     (dylan::keyword-validate next-method rest '(test: stable:))
  323.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:<)))
  324.       (stable (dylan::find-keyword rest 'stable: (lambda () #F))))
  325.       stable                ; Ignored
  326.       (dylan-call dylan:set-array-value!
  327.           s-vector
  328.           (dylan-call dylan:as
  329.                   <simple-object-vector>
  330.                   (sort (dylan-call dylan:as <pair> s-vector)
  331.                     (lambda (x y)
  332.                       (dylan-call test? x y)))))))))
  333.  
  334. (add-method dylan:first
  335.   (dylan::function->method one-vector
  336.     (lambda (vector)
  337.       (if (= (vector-length vector) 0)
  338.       (dylan-call dylan:error "(first <vector>) -- vector is empty" vector)
  339.       (vector-ref vector 0)))))
  340.  
  341. (add-method dylan:second
  342.   (dylan::function->method one-vector
  343.     (lambda (vector)
  344.       (if (< (vector-length vector) 2)
  345.       (dylan-call dylan:error
  346.               "(second <vector>) -- vector doesn't have 2 elements"
  347.               vector)
  348.       (vector-ref vector 1)))))
  349.  
  350. (add-method dylan:third
  351.   (dylan::function->method one-vector
  352.     (lambda (vector)
  353.       (if (< (vector-length vector) 3 )
  354.       (dylan-call dylan:error
  355.               "(third <vector>) -- vector doesn't have 3 elements"
  356.               vector)
  357.       (vector-ref vector 2)))))
  358.  
  359. (add-method dylan:last
  360.   (dylan::function->method one-vector
  361.     (lambda (vector)
  362.       (let* ((vector-value (dylan-call dylan:get-array-value vector))
  363.          (vl (vector-length vector-value)))
  364.     (if (zero? vl)
  365.         (dylan-call dylan:error "(last <vector>) -- vector is empty" vector)
  366.         (vector-ref vector-value (- vl 1)))))))
  367.  
  368. (define dylan:vector
  369.   (dylan::function->method
  370.     (make-param-list '() #F 'REST-ARGS #F)
  371.     (lambda args
  372.       (if (null? args)
  373.       (vector)
  374.       (apply vector args)))))
  375.  
  376. (add-method dylan:current-key
  377.   (dylan::function->method
  378.    (make-param-list `((VECTOR ,<vector>) (STATE ,<object>)) #F #F #F)
  379.    (lambda (vector state)
  380.      vector                ; Ignored
  381.      (vector-ref state 0))))
  382.  
  383. ;;;
  384. ;;; Collection Keys
  385. ;;;
  386.  
  387. (add-method
  388.  dylan:element
  389.  (dylan::dylan-callable->method
  390.   (make-param-list `((VECTOR ,<vector>) (INDEX ,<integer>)) #F #F '(default:))
  391.   (lambda (multiple-values next-method vector index . rest)
  392.     multiple-values
  393.     (dylan::keyword-validate next-method rest '(default:))
  394.     (let ((vector-value (dylan-call dylan:get-array-value vector)))
  395.       (let ((size (vector-length vector-value)))
  396.     (if (and (>= index 0) (< index size))
  397.         (vector-ref vector-value index)
  398.         (dylan::find-keyword
  399.          rest '(default:)
  400.          (lambda ()
  401.            (dylan-call dylan:error "(element <vector> <integer>) -- invalid index with no default value" vector-value index)))))))))
  402.  
  403. ;;;
  404. ;;; Mutable Collections
  405. ;;;
  406.  
  407. (add-method dylan:setter/current-element/
  408.   (dylan::function->method
  409.     (make-param-list
  410.      `((SOV ,<simple-object-vector>) (STATE ,<object>) (new-value ,<object>))
  411.        #F #F #F)
  412.     (lambda (sov state new-value)
  413.       (vector-set! sov (vector-ref state 0) new-value)
  414.       new-value)))
  415.  
  416. (add-method dylan:setter/current-element/
  417.   (dylan::function->method
  418.     (make-param-list `((STRETCHY-VECTOR ,<stretchy-vector>)
  419.                (STATE ,<object>)
  420.                (new-value ,<object>))
  421.      #F #F #F)
  422.     (lambda (st-vector state new-value)
  423.       (vector-set! (dylan-call dylan:get-array-value st-vector)
  424.            (vector-ref state 0) new-value)
  425.       new-value)))
  426.  
  427. (add-method dylan:setter/element/
  428.   (dylan::function->method
  429.     (make-param-list
  430.      `((VECTOR ,<vector>) (INDEX ,<object>) (NEW-VALUE ,<object>)) #F #F #F)
  431.     (lambda (vector-instance index new-value)
  432.       (let ((vector (dylan-call dylan:get-array-value vector-instance)))
  433.     (vector-set! vector index new-value)
  434.     new-value))))
  435.