home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / run-collections-list.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  14.9 KB  |  512 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-list.scm,v 1.17 1992/08/31 05:00:58 birkholz Exp $
  39.  
  40. ;;;; This file contains all the specializations for list, pair, and
  41. ;;;; empty-list type.
  42.  
  43.  
  44. (add-method dylan:binary=
  45.   (dylan::function->method
  46.    two-lists
  47.    (lambda (list-1 list-2)
  48.      (let ((size-1 (dylan-call dylan:size list-1))
  49.        (size-2 (dylan-call dylan:size list-2)))
  50.        (if (not (= size-1 size-2))
  51.        #F
  52.        (do ((state-1 (dylan-call dylan:initial-state list-1)
  53.              (dylan-call dylan:next-state list-1 state-1))
  54.         (state-2 (dylan-call dylan:initial-state list-2)
  55.              (dylan-call dylan:next-state list-2 state-2)))
  56.            ((or (or (not state-1) (not state-2))
  57.             (not (dylan-call dylan:id?
  58.                      (dylan-call dylan:current-element
  59.                          list-1 state-1)
  60.                      (dylan-call dylan:current-element
  61.                          list-2 state-2))))
  62.         (if (or state-1 state-2) #F #T))))))))
  63.  
  64. (add-method dylan:as
  65.   (dylan::function->method
  66.    (make-param-list `((CLASS ,(dylan::make-singleton <list>))
  67.               (COLLECTION ,<collection>)) #F #F #F)
  68.    (lambda (class collection)
  69.      class
  70.      (if (dylan-call dylan:instance? collection <list>)
  71.      collection
  72.      (let loop ((state (dylan-call dylan:initial-state collection))
  73.             (result '()))
  74.        (if state
  75.            (loop (dylan-call dylan:next-state collection state)
  76.              (cons (dylan-call dylan:current-element collection state)
  77.                result))
  78.            (reverse result)))))))
  79.  
  80.  
  81. (add-method dylan:as
  82.   (dylan::function->method
  83.    (make-param-list `((CLASS ,(dylan::make-singleton <pair>))
  84.               (COLLECTION ,<collection>)) #F #F #F)
  85.    (lambda (class collection)
  86.      class
  87.      (if (dylan-call dylan:instance? collection <pair>)
  88.      collection
  89.      (let loop ((state (dylan-call dylan:initial-state collection))
  90.             (result '()))
  91.        (if state
  92.            (loop (dylan-call dylan:next-state collection state)
  93.              (cons (dylan-call dylan:current-element collection state)
  94.                result))
  95.            (reverse result)))))))
  96.  
  97.  
  98. ;;;
  99. ;;; LIST SPECIALIZED MAKE
  100. ;;; supports size: and fill:
  101. ;;;
  102. (add-method
  103.  dylan:make
  104.  (dylan::dylan-callable->method
  105.   (make-param-list `((LIST ,(dylan::make-singleton <list>)))
  106.            #F #F '(size: fill:))
  107.   (lambda (multiple-values next-method class . rest)
  108.     multiple-values class                ; Not used
  109.     (dylan::keyword-validate next-method rest '(size: fill:))
  110.     (let* ((size (dylan::find-keyword rest 'size: (lambda () 0)))
  111.        (have-fill? #T)
  112.        (fill (dylan::find-keyword rest 'fill:
  113.                       (lambda () (set! have-fill? #F) #F))))
  114.       (if (or (not (integer? size)) (negative? size))
  115.       (dylan-call dylan:error
  116.               "make -- list size: invalid" size))
  117.       (vector->list (make-vector size fill))))))
  118. ;;;
  119. ;;; PAIR SPECIALIZED MAKE
  120. ;;;
  121. (add-method
  122.  dylan:make
  123.  (dylan::dylan-callable->method
  124.   (make-param-list `((PAIR ,(dylan::make-singleton <pair>)))
  125.            #F #F '(size: fill:))
  126.   (lambda (multiple-values next-method class . rest)
  127.     multiple-values class                ; Not used
  128.     (dylan::keyword-validate next-method rest '(size: fill:))
  129.     (let* ((size (dylan::find-keyword rest 'size: (lambda () 0)))
  130.        (have-fill? #T)
  131.        (fill (dylan::find-keyword rest 'fill:
  132.                       (lambda () (set! have-fill? #F) #F))))
  133.       (if (or (not (integer? size)) (negative? size))
  134.       (dylan-call dylan:error "make -- list size invalid" size))
  135.       (vector->list (make-vector size fill))))))
  136. ;;;
  137. ;;; EMPTY-LIST SPECIALIZED MAKE
  138. ;;;
  139. (add-method
  140.  dylan:make
  141.  (dylan::dylan-callable->method
  142.   (make-param-list `((EMPTY-LIST ,(dylan::make-singleton <empty-list>)))
  143.            #F #F '(size: fill:))
  144.   (lambda (multiple-values next-method class . rest)
  145.     multiple-values class        ; Not used
  146.     (dylan::keyword-validate next-method rest '(size: fill:))
  147.     '())))
  148.  
  149.  
  150. ;;;
  151. ;;; FUNCTIONS FOR COLLECTIONS (page 99)
  152. ;;;
  153. (add-method dylan:size
  154.   (one-arg 'LIST <list>
  155.     (lambda (list)
  156.       (let ((length (dylan-list-length list)))
  157.     (if (= length -1)
  158.         #F
  159.         length)))))
  160.  
  161. (add-method dylan:size
  162.   (one-arg 'PAIR <empty-list>
  163.    (lambda (pair) pair 0)))
  164.  
  165. (add-method
  166.  dylan:member?
  167.  (dylan::dylan-callable->method
  168.   (make-param-list `((VALUE ,<object>) (COLLECTION ,<list>))
  169.            #F #F '(test:))
  170.   (lambda (multiple-values next-method value list . keys)
  171.     multiple-values
  172.     (dylan::keyword-validate next-method keys '(test:))
  173.     (let ((test (dylan::find-keyword keys 'test:
  174.                      (lambda () dylan:id?))))
  175.       (let loop ((list list))
  176.     (cond ((null? list) #F)
  177.           ((dylan-call test value (car list)) list)
  178.           (else (loop (cdr list)))))))))
  179.  
  180. ;;;;
  181. ;;;; Functions for Sequences (page 104)
  182. ;;;;
  183.  
  184. (add-method dylan:add
  185.  (dylan::function->method one-list-and-an-object
  186.   (lambda (the-list new-element)
  187.     (apply list new-element the-list))))
  188.  
  189. (add-method dylan:add!
  190.  (dylan::function->method
  191.   one-list-and-an-object
  192.   (lambda (list-1 val)
  193.     (dylan-call dylan:cons val list-1)))) ; Like the book (p. 117)
  194.  
  195. (add-method dylan:concatenate
  196.   (dylan::function->method at-least-one-list
  197.     (lambda (list-1 . rest)
  198.       (let ((rest-lists (map (lambda (seq)
  199.                    (dylan-call dylan:as <pair> seq))
  200.                  rest)))
  201.     (apply append (cons list-1 rest-lists))))))
  202.  
  203. (add-method dylan:reverse
  204.   (dylan::function->method one-list reverse))
  205.  
  206. (add-method dylan:first
  207.   (dylan::function->method one-list
  208.     (lambda (list)
  209.       (if (null? list)
  210.       (dylan-call dylan:error "first -- list is empty" list)
  211.       (car list)))))
  212.  
  213. (add-method dylan:second
  214.   (dylan::function->method one-list
  215.     (lambda (list)
  216.       (if (or (null? list) (null? (cdr list)))
  217.       (dylan-call dylan:error "second -- list doesn't have 2 elements" list)
  218.       (cadr list)))))
  219.  
  220. (add-method dylan:third
  221.   (dylan::function->method one-list
  222.     (lambda (list)
  223.       (if (or (null? list) (null? (cdr list))
  224.           (null? (cddr list)))
  225.       (dylan-call dylan:error "third -- list doesn't have 3 elements" list)
  226.       (caddr list)))))
  227.  
  228. (add-method dylan:last
  229.   (dylan::function->method one-list
  230.     (lambda (list)
  231.       (if (null? list)
  232.       (dylan-call dylan:error "last -- list is empty")
  233.       (last list)))))
  234.  
  235. ;;;;
  236. ;;;; Operations on LISTS (page 115)
  237. ;;;;
  238. (define dylan:cons
  239.   (dylan::function->method two-objects cons))
  240.  
  241. (define dylan:list
  242.   (dylan::function->method only-rest-args list))
  243.  
  244. (define dylan:car
  245.   (dylan::function->method
  246.    one-list
  247.    (lambda (list) (if (null? list) '() (car list)))))
  248.  
  249. (define dylan:cdr
  250.   (dylan::function->method
  251.    one-list
  252.    (lambda (list) (if (null? list) '() (cdr list)))))
  253.  
  254. (define dylan:caar
  255.   (dylan::function->method
  256.    one-list
  257.    (lambda (list) (dylan-call dylan:car (dylan-call dylan:car list)))))
  258.  
  259. (define dylan:cadr
  260.   (dylan::function->method
  261.    one-list
  262.    (lambda (list) (dylan-call dylan:car (dylan-call dylan:cdr list)))))
  263.  
  264. (define dylan:cdar
  265.   (dylan::function->method
  266.    one-list
  267.    (lambda (list) (dylan-call dylan:cdr (dylan-call dylan:car list)))))
  268.  
  269. (define dylan:cddr
  270.   (dylan::function->method
  271.    one-list
  272.    (lambda (list) (dylan-call dylan:cdr (dylan-call dylan:cdr list)))))
  273.  
  274. (define dylan:caaar
  275.   (dylan::function->method
  276.    one-list
  277.    (lambda (list)
  278.      (dylan-call dylan:car
  279.          (dylan-call dylan:car (dylan-call dylan:car list))))))
  280.  
  281. (define dylan:caadr
  282.   (dylan::function->method
  283.    one-list
  284.    (lambda (list)
  285.      (dylan-call dylan:car
  286.          (dylan-call dylan:car (dylan-call dylan:cdr list))))))
  287.  
  288. (define dylan:cadar
  289.   (dylan::function->method
  290.    one-list
  291.    (lambda (list)
  292.      (dylan-call dylan:car
  293.          (dylan-call dylan:cdr (dylan-call dylan:car list))))))
  294.  
  295. (define dylan:caddr
  296.   (dylan::function->method
  297.    one-list
  298.    (lambda (list)
  299.      (dylan-call dylan:car
  300.          (dylan-call dylan:cdr (dylan-call dylan:cdr list))))))
  301.  
  302. (define dylan:cdaar
  303.   (dylan::function->method
  304.    one-list
  305.    (lambda (list)
  306.      (dylan-call dylan:cdr
  307.          (dylan-call dylan:car (dylan-call dylan:car list))))))
  308.  
  309. (define dylan:cdadr
  310.   (dylan::function->method
  311.    one-list
  312.    (lambda (list)
  313.      (dylan-call dylan:cdr
  314.          (dylan-call dylan:car (dylan-call dylan:cdr list))))))
  315.  
  316. (define dylan:cddar
  317.   (dylan::function->method
  318.    one-list
  319.    (lambda (list)
  320.      (dylan-call dylan:cdr
  321.          (dylan-call dylan:cdr (dylan-call dylan:car list))))))
  322.  
  323. (define dylan:cdddr
  324.   (dylan::function->method
  325.    one-list
  326.    (lambda (list)
  327.      (dylan-call dylan:cdr
  328.          (dylan-call dylan:cdr (dylan-call dylan:cdr list))))))
  329.  
  330. (define dylan:setter/car/
  331.   (dylan::function->method
  332.    one-list-and-an-object
  333.    (lambda (list object) (set-car! list object) object)))
  334.  
  335. (define dylan:setter/cdr/
  336.   (dylan::function->method
  337.    one-list-and-an-object
  338.    (lambda (list object) (set-cdr! list object) object)))
  339.  
  340. (define dylan:setter/caar/
  341.   (dylan::function->method
  342.    one-list-and-an-object
  343.    (lambda (list object)
  344.      (set-car! (dylan-call dylan:car list) object)
  345.      object)))
  346.  
  347. (define dylan:setter/cadr/
  348.   (dylan::function->method
  349.    one-list-and-an-object
  350.    (lambda (list object)
  351.      (set-car! (dylan-call dylan:cdr list) object)
  352.      object)))
  353.  
  354. (define dylan:setter/cdar/
  355.   (dylan::function->method
  356.    one-list-and-an-object
  357.    (lambda (list object)
  358.      (set-cdr! (dylan-call dylan:car list) object)
  359.      object)))
  360.  
  361. (define dylan:setter/cddr/
  362.   (dylan::function->method
  363.    one-list-and-an-object
  364.    (lambda (list object)
  365.      (set-cdr! (dylan-call dylan:cdr list) object)
  366.      object)))
  367.  
  368. (define dylan:setter/caaar/
  369.   (dylan::function->method
  370.    one-list-and-an-object
  371.    (lambda (list object)
  372.      (set-car! (dylan-call dylan:car (dylan-call dylan:car list)) object)
  373.      object)))
  374.  
  375. (define dylan:setter/caadr/
  376.   (dylan::function->method
  377.    one-list-and-an-object
  378.    (lambda (list object)
  379.      (set-car! (dylan-call dylan:car (dylan-call dylan:cdr list)) object)
  380.      object)))
  381.  
  382. (define dylan:setter/cadar/
  383.   (dylan::function->method
  384.    one-list-and-an-object
  385.    (lambda (list object)
  386.      (set-car! (dylan-call dylan:cdr (dylan-call dylan:car list)) object)
  387.      object)))
  388.  
  389. (define dylan:setter/caddr/
  390.   (dylan::function->method
  391.    one-list-and-an-object
  392.    (lambda (list object)
  393.      (set-car! (dylan-call dylan:cdr (dylan-call dylan:cdr list)) object)
  394.      object)))
  395.  
  396. (define dylan:setter/cdaar/
  397.   (dylan::function->method
  398.    one-list-and-an-object
  399.    (lambda (list object)
  400.      (set-cdr! (dylan-call dylan:car (dylan-call dylan:car list)) object)
  401.      object)))
  402.  
  403. (define dylan:setter/cdadr/
  404.   (dylan::function->method
  405.    one-list-and-an-object
  406.    (lambda (list object)
  407.      (set-cdr! (dylan-call dylan:car (dylan-call dylan:cdr list)) object)
  408.      object)))
  409.  
  410. (define dylan:setter/cddar/
  411.   (dylan::function->method
  412.    one-list-and-an-object
  413.    (lambda (list object)
  414.      (set-cdr! (dylan-call dylan:cdr (dylan-call dylan:car list)) object)
  415.      object)))
  416.  
  417. (define dylan:setter/cdddr/
  418.   (dylan::function->method
  419.    one-list-and-an-object
  420.    (lambda (list object)
  421.      (set-cdr! (dylan-call dylan:cdr (dylan-call dylan:cdr list)) object)
  422.      object)))
  423.  
  424. (define dylan:list*
  425.   (dylan::function->method
  426.    only-rest-args
  427.    (let ()
  428.      (define (list* arg . args)
  429.        (if (null? args)
  430.        arg
  431.        (cons arg (apply list* args))))
  432.      (lambda args
  433.        (if (null? args)
  434.        '()                ; Very peculiar ?
  435.        (apply list* args))))))
  436.  
  437. (define dylan:append
  438.   (dylan::generic-fn 'append at-least-one-list append))
  439.  
  440. (define dylan:find-pair
  441.   (dylan::generic-fn
  442.    'find-pair
  443.    (make-param-list `((ITEM ,<object>) (LIST ,<list>)) #F #F '(test:))
  444.    #F))
  445.  
  446. (add-method
  447.  dylan:find-pair
  448.  (dylan::dylan-callable->method
  449.   (make-param-list `((ITEM ,<object>) (LIST ,<list>)) #F #F '(test:))
  450.   (lambda (multiple-values next-method item list . rest)
  451.     multiple-values
  452.     (dylan::keyword-validate next-method rest '(test:))
  453.     (let ((test-fn (dylan::find-keyword rest 'test:
  454.                     (lambda () dylan:id?))))
  455.       (let loop ((rest-list list))
  456.     (cond ((null? rest-list) #F)
  457.           ((not (pair? (car list)))
  458.            (dylan-call dylan:error
  459.                "find-pair -- list element not a pair"
  460.                (car rest-list)))
  461.           ((dylan-call test-fn item (caar rest-list))
  462.            (car rest-list))
  463.           (else (loop (cdr rest-list)))))))))
  464.  
  465.  
  466.  
  467. ;;;
  468. ;;; Collection Keys
  469. ;;;
  470.  
  471. (add-method
  472.  dylan:element
  473.  (dylan::dylan-callable->method
  474.   (make-param-list `((LIST ,<list>) (INDEX ,<integer>)) #F #F '(default:))
  475.   (lambda (multiple-values next-method list-1 index . rest)
  476.     multiple-values
  477.     (dylan::keyword-validate next-method rest '(default:))
  478.     (let ((size (length list-1)))
  479.       (if (and (>= index 0) (< index size))
  480.       (list-ref list-1 index)
  481.       (dylan::find-keyword
  482.        rest
  483.        'default:
  484.        (lambda ()
  485.          (dylan-call dylan:error
  486.              "element -- invalid index with no default value"
  487.              list-1 index))))))))
  488.  
  489. ;;;
  490. ;;; Mutable Collection
  491. ;;;
  492.  
  493. (add-method dylan:setter/current-element/
  494.   (dylan::function->method
  495.     (make-param-list
  496.      `((LIST ,<list>) (STATE ,<object>) (new-value ,<object>)) #F #F #F)
  497.     (lambda (list state new-value)
  498.       list                ; Ignored
  499.       (set-car! state new-value)
  500.       new-value)))
  501.  
  502.  
  503. (add-method dylan:setter/current-element/
  504.   (dylan::function->method
  505.     (make-param-list
  506.      `((EMPTY-LIST ,<empty-list>) (STATE ,<object>) (new-value ,<object>))
  507.      #F #F #F)
  508.     (lambda (empty-list state new-value)
  509.       (dylan-call dylan:error
  510.           "setter/current-element/ for <empty-list>: not possible"
  511.           empty-list state new-value))))
  512.