home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / run-collections-string.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  11.6 KB  |  352 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-string.scm,v 1.17 1992/08/31 05:26:50 birkholz Exp $
  39.  
  40. ;;;; Specializations for string and byte-string types.
  41.  
  42. (add-method dylan:as
  43.   (dylan::function->method
  44.    (make-param-list `((CLASS ,(dylan::make-singleton <byte-string>))
  45.               (COLLECTION ,<collection>)) #F #F #F)
  46.    (lambda (class collection)
  47.      class
  48.      (if (dylan-call dylan:instance? collection <byte-string>)
  49.      collection
  50.      (let* ((size (dylan-call dylan:size collection))
  51.         (new-string (make-string size)))
  52.        (do ((state (dylan-call dylan:initial-state collection)
  53.                (dylan-call dylan:next-state collection state))
  54.         (index 0 (+ index 1)))
  55.            ((not state) new-string)
  56.          (let ((cur-element
  57.             (dylan-call dylan:current-element collection state)))
  58.            (string-set! new-string index
  59.                 (dylan-call
  60.                  dylan:as <character> cur-element)))))))))
  61.  
  62. (add-method dylan:as
  63.   (dylan::function->method
  64.    (make-param-list `((CLASS ,(dylan::make-singleton <string>))
  65.               (COLLECTION ,<collection>)) #F #F #F)
  66.    (lambda (class collection)
  67.      class
  68.      (if (dylan-call dylan:instance? collection <string>)
  69.      collection
  70.      (dylan-call dylan:as <byte-string> collection)))))
  71.  
  72. ;;;
  73. ;;; BYTE-STRING MAKE yields a Scheme string
  74. ;;;
  75. ;;; size keyword overrides inherited dimensions keyword (which is not used)
  76. ;;;
  77. (add-method
  78.  dylan:make
  79.  (dylan::dylan-callable->method
  80.   (make-param-list `((STRING ,(dylan::make-singleton <byte-string>)))
  81.            #F #F '(size: fill:))
  82.   (lambda (multiple-values next-method class . rest)
  83.     multiple-values class                ; Not used
  84.     (dylan::keyword-validate next-method rest '(size: fill:))
  85.     (let* ((size (dylan::find-keyword rest 'size: (lambda () 0)))
  86.        (have-fill? #T)
  87.        (fill (dylan::find-keyword rest 'fill:
  88.                       (lambda () (set! have-fill? #F) #F))))
  89.       (if (or (not (integer? size)) (negative? size))
  90.       (dylan-call dylan:error
  91.               "(make (singleton <string>)) -- size: invalid" size))
  92.       (if (and have-fill? (not (char? fill)))
  93.       (dylan-call dylan:error
  94.               "(make (singleton <string>)) -- fill: not a character"
  95.               fill))
  96.       (if have-fill?
  97.       (make-string size fill)
  98.       (make-string size))))))
  99.  
  100. ;;;
  101. ;;; STRING SPECIALIZED MAKE
  102. ;;; And we'll make <string> turn into <byte-string>
  103. ;;;
  104. (add-method dylan:make
  105.   (dylan::function->method
  106.    (make-param-list `((STRING ,(dylan::make-singleton <string>)))
  107.             #F #F #T)
  108.    (lambda (class . rest)
  109.      class                ; Ignored
  110.      (dylan-apply dylan:make <byte-string> rest))))
  111.  
  112.  
  113. ;;;
  114. ;;; UNICODE-STRING SPECIALIZED MAKE
  115. ;;; <unicode-string> not supported
  116. ;;;
  117. (add-method dylan:make
  118.   (dylan::function->method
  119.    (make-param-list `((UNICODE
  120.                ,(dylan::make-singleton <unicode-string>)))
  121.             #F #F #T)
  122.    (lambda (class . rest)
  123.      class                ; Ignored
  124.      rest                ; Ignored
  125.      (dylan-call dylan:error
  126.          "(make (singleton <unicode-string>)) -- not supported"))))
  127.  
  128. ;;;
  129. ;;; FUNCTIONS FOR COLLECTIONS (page 99)
  130. ;;;
  131. (add-method dylan:size
  132.   (one-arg 'STRING <byte-string>
  133.     (lambda (string) (string-length string))))
  134.  
  135. (add-method dylan:class-for-copy
  136.   (dylan::function->method one-string (lambda (x) x <byte-string>)))
  137.  
  138. ;;;;
  139. ;;;; Functions for Sequences (page 104)
  140. ;;;;
  141. (add-method dylan:add
  142.   (dylan::function->method one-byte-string-and-an-object
  143.     (lambda (the-string new-element)
  144.       (if (char? new-element)
  145.       (string-append (string new-element) the-string)
  146.       (dylan-call dylan:error "(add <byte-string> <object>) -- cannot add a non-character to string" the-string new-element)))))
  147.  
  148. (add-method dylan:concatenate
  149.   (dylan::function->method
  150.     (make-param-list `((BYTE-STRING ,<byte-string>)) #F 'REST #F)
  151.     (lambda (string-1 . rest)
  152.       (let loop ((result string-1)
  153.          (rest-strings
  154.           (map (lambda (seq)
  155.              (dylan-call dylan:as <byte-string> seq))
  156.                rest)))
  157.     (if (null? rest-strings)
  158.         result
  159.         (loop (string-append result (car rest-strings))
  160.           (cdr rest-strings)))))))
  161.  
  162. (add-method dylan:concatenate
  163.   (dylan::function->method
  164.     (make-param-list `((STRING ,<string>)) #F 'REST #F)
  165.     (lambda (string-1 . rest)
  166.       (dylan-call dylan:apply dylan:concatenate string-1 rest))))
  167.  
  168. (add-method dylan:reverse
  169.   (dylan::function->method one-byte-string
  170.     (lambda (string-1)
  171.       (let ((result (make-string (string-length string-1))))
  172.     (do ((from (- (string-length string-1) 1) (- from 1))
  173.          (to 0 (+ to 1)))
  174.         ((< from 0) result)
  175.       (string-set! result to (string-ref string-1 from))
  176.       result)))))
  177.  
  178. (add-method dylan:reverse!
  179.   (dylan::function->method one-byte-string
  180.     (lambda (string-1)
  181.       (do ((from (- (string-length string-1) 1) (- from 1))
  182.        (to 0 (+ to 1)))
  183.       ((<= from to) string-1)
  184.     (let ((to-char (string-ref string-1 to)))
  185.       (string-set! string-1 to (string-ref string-1 from))
  186.       (string-set! string-1 from to-char))))))
  187.  
  188. (add-method dylan:first
  189.   (dylan::function->method one-string
  190.     (lambda (string)
  191.       (if (= (string-length string) 0)
  192.       (dylan-call dylan:error "(first <string>) -- string is empty" string)
  193.       (string-ref string 0)))))
  194.  
  195. (add-method dylan:first
  196.   (dylan::function->method one-byte-string
  197.     (lambda (string)
  198.       (if (= (string-length string) 0)
  199.       (dylan-call dylan:error
  200.               "(first <byte-string>) -- byte-string is empty" string)
  201.       (string-ref string 0)))))
  202.  
  203. (add-method dylan:second
  204.   (dylan::function->method one-string
  205.     (lambda (string)
  206.       (if (< (string-length string) 2)
  207.       (dylan-call dylan:error
  208.               "(second <string>) -- string doesn't have 2 elements"
  209.               string)
  210.       (string-ref string 1)))))
  211.  
  212. (add-method dylan:second
  213.   (dylan::function->method one-byte-string
  214.     (lambda (string)
  215.       (if (< (string-length string) 2)
  216.       (dylan-call dylan:error
  217.               "(second <string>) -- string doesn't have 2 elements"
  218.               string)
  219.       (string-ref string 1)))))
  220.  
  221. (add-method dylan:third
  222.   (dylan::function->method one-string
  223.     (lambda (string)
  224.       (if (< (string-length string) 3 )
  225.       (dylan-call dylan:error
  226.               "(third <string>) -- string doesn't have 3 elements"
  227.               string)
  228.       (string-ref string 2)))))
  229.  
  230. (add-method dylan:third
  231.   (dylan::function->method one-byte-string
  232.     (lambda (string)
  233.       (if (< (string-length string) 3 )
  234.       (dylan-call dylan:error
  235.               "(third <byte-string>) -- string doesn't have 3 elements"
  236.               string)
  237.       (string-ref string 2)))))
  238.  
  239. (add-method dylan:last
  240.   (dylan::function->method one-string
  241.     (lambda (string)
  242.       (let ((sl (string-length string)))
  243.     (if (zero? sl)
  244.         (dylan-call dylan:error "(last <string>) -- string is empty" string)
  245.         (string-ref string (- sl 1)))))))
  246.  
  247. (add-method dylan:last
  248.   (dylan::function->method one-byte-string
  249.     (lambda (string)
  250.       (let ((sl (string-length string)))
  251.     (if (zero? sl)
  252.         (dylan-call dylan:error
  253.             "(last <byte-string>) -- byte-string is empty" string)
  254.         (string-ref string (- sl 1)))))))
  255.  
  256. ;;;; Operations on Strings (page 119)
  257.  
  258. (add-method dylan:binary< (dylan::function->method two-strings string<?))
  259.  
  260. ;; Generic function dylan:as-lowercase defined in runtime-functions.scm.
  261.  
  262. (add-method
  263.  dylan:as-lowercase
  264.  (dylan::function->method
  265.   (make-param-list `((BYTE-STRING ,<byte-string>)) #F #F #F)
  266.   (lambda (string)
  267.     (list->string (map (lambda (char) (char-downcase char))
  268.                (string->list string))))))
  269.  
  270. (define dylan:as-lowercase!
  271.   (dylan::generic-fn 'as-lowercase! one-string #F))
  272.  
  273. (add-method
  274.  dylan:as-lowercase!
  275.  (dylan::function->method
  276.   (make-param-list `((BYTE-STRING ,<byte-string>)) #F #F #F)
  277.   (lambda (string)
  278.     (do ((index 0 (+ index 1)))
  279.     ((>= index (string-length string)) string)
  280.       (string-set! string index (char-downcase (string-ref string index)))))))
  281.  
  282. ;; Generic function dylan:as-uppercase defined in runtime-functions.scm.
  283.  
  284. (add-method
  285.  dylan:as-uppercase
  286.  (dylan::function->method
  287.   (make-param-list `((BYTE-STRING ,<byte-string>)) #F #F #F)
  288.   (lambda (string)
  289.     (list->string (map (lambda (char) (char-upcase char))
  290.                (string->list string))))))
  291.  
  292. (define dylan:as-uppercase!
  293.   (dylan::generic-fn 'as-uppercase! one-string #F))
  294.  
  295. (add-method
  296.  dylan:as-uppercase!
  297.  (dylan::function->method
  298.   (make-param-list `((BYTE-STRING ,<byte-string>)) #F #F #F)
  299.   (lambda (string)
  300.     (do ((index 0 (+ index 1)))
  301.     ((>= index (string-length string)) string)
  302.       (string-set! string index (char-upcase (string-ref string index)))))))
  303.  
  304.  
  305. (add-method dylan:previous-state    ; Not specified in the manual
  306.   (dylan::function->method
  307.    (make-param-list `((STRING ,<string>) (STATE ,<number>)) #F #F #F)
  308.    (lambda (string offset)
  309.      string                ; unused
  310.      (if (= offset 0) #F (- offset 1)))))
  311.  
  312.  
  313. ;;;
  314. ;;; Collection Keys
  315. ;;;
  316. (add-method
  317.  dylan:element
  318.  (dylan::dylan-callable->method
  319.   (make-param-list `((BYTE-STRING ,<byte-string>) (INDEX ,<integer>))
  320.            #F #F '(default:))
  321.   (lambda (multiple-values next-method string-value index . rest)
  322.     multiple-values
  323.     (dylan::keyword-validate next-method rest '(default:))
  324.     (let ((size (string-length string-value)))
  325.       (if (and (>= index 0) (< index size))
  326.       (string-ref string-value index)
  327.       (dylan::find-keyword
  328.        rest '(default:)
  329.        (lambda ()
  330.          (dylan-call dylan:error "(element <byte-string> <integer>) -- invalid index with no default value" string-value index))))))))
  331.  
  332. ;;;
  333. ;;; Mutable Collections
  334. ;;;
  335. (add-method dylan:setter/current-element/
  336.   (dylan::function->method
  337.     (make-param-list
  338.      `((BYTE-STRING ,<byte-string>) (STATE ,<object>) (new-value ,<object>))
  339.        #F #F #F)
  340.     (lambda (the-string state new-value)
  341.       (string-set! the-string (vector-ref state 0) new-value)
  342.       new-value)))
  343.  
  344. (add-method dylan:setter/element/
  345.   (dylan::function->method
  346.     (make-param-list
  347.      `((BYTE-STRING ,<byte-string>) (INDEX ,<object>) (NEW-VALUE ,<object>))
  348.      #F #F #F)
  349.     (lambda (string index new-value)
  350.       (string-set! string index new-value)
  351.       new-value)))
  352.