home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / EMACROS.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  7.9 KB  |  183 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. ;;;
  43.  
  44. (begin
  45.   (define-integrable substring-find-next-char
  46.                      substring-find-next-char-in-set)
  47.   (define-integrable substring-find-previous-char
  48.                      substring-find-previous-char-in-set)
  49. )
  50. ;;;; Replace Group
  51.  
  52. (define (string-replace string char1 char2)
  53.   (let ((string (string-copy string)))
  54.     (string-replace! string char1 char2)
  55.     string))
  56.  
  57. (define (substring-replace string start end char1 char2)
  58.   (let ((string (string-copy string)))
  59.     (substring-replace! string start end char1 char2)
  60.     string))
  61.  
  62. (define (string-replace! string char1 char2)
  63.   (substring-replace! string 0 (string-length string) char1 char2))
  64.  
  65. (define (substring-replace! string start end char1 char2)
  66.   (define (loop start)
  67.     (let ((index (substring-find-next-char string start end char1)))
  68.       (if index
  69.       (sequence (string-set! string index char2)
  70.             (loop (1+ index))))))
  71.   (loop start))
  72.  
  73. (define string-uppercase '())
  74. (let ()
  75.   (define (string-set-case char-set-case)
  76.     (lambda (string1)
  77.       (let ((end (string-length string1)))
  78.         (define (loop string2 string1 index char-set-case end)
  79.           (if (= index end)
  80.               string2
  81.               (begin (string-set! string2
  82.                                   index
  83.                                   (char-set-case (string-ref string1 index)))
  84.                      (loop string2 string1 (1+ index) char-set-case end))))
  85.         (loop (make-string end '()) string1 0 char-set-case end))))
  86.   (set! string-uppercase (string-set-case char-upcase)))
  87.  
  88. (define map2
  89.   (lambda (fn arg1 arg2)
  90.     (cond ((or (null? arg1) (null? arg2)) '())
  91.           (else (cons (fn (car arg1) (car arg2))
  92.                    (map2 fn (cdr arg1) (cdr arg2)))))))
  93.  
  94. (macro define-named-structure
  95.   (lambda (e)
  96.     (let ((name (cadr e)) (slots (cddr e)))
  97.          (define ((make-symbols x) y) (make-symbol x y))
  98.          (define (make-symbol . args)
  99.                  (string->symbol (apply string-append args)))
  100.      (let ((structure-string (string-uppercase name))
  101.                (slot-strings (mapcar symbol->string slots)))
  102.               (let ((prefix (string-append structure-string "-")))
  103.                    (let ((structure-name (string->symbol structure-string))
  104.                          (tag-name (make-symbol "%" prefix "TAG"))
  105.                          (constructor-name
  106.                           (make-symbol "%MAKE-" structure-string))
  107.                          (predicate-name (make-symbol structure-string "?"))
  108.                          (slot-names
  109.                           (mapcar (make-symbols
  110.                                    (string-append prefix "INDEX:"))
  111.                                   slot-strings))
  112.                          (selector-names
  113.                           (mapcar (make-symbols prefix) slot-strings)))
  114.                         (define (slot-loop tail slot-names n)
  115.                                 (if (null? slot-names)
  116.                                     tail
  117.                                     (slot-loop (cons (list 'DEFINE-INTEGRABLE
  118.                                                            (car
  119.                                                             slot-names)
  120.                                                            n)
  121.                                                      tail)
  122.                                                (cdr slot-names)
  123.                                                (|1+| n))))
  124.                         (define (selector-loop tail selector-names n)
  125.                                 (if (null? selector-names)
  126.                                     tail
  127.                                     (selector-loop
  128.                                       (cons `(define-integrable
  129.                                                ,(car selector-names)
  130.                                                  (lambda (,structure-name)
  131.                                                   (vector-ref ,structure-name
  132.                                                               ,n)))
  133.                                              tail)
  134.                                        (cdr selector-names)
  135.                                        (|1+| n))))
  136.                         `(begin
  137.                            (define ,tag-name ,name)
  138.                            (define (,constructor-name)
  139.                              (let ((,structure-name
  140.                                     (make-vector ,(1+ (length slots)) '())))
  141.                                (vector-set! ,structure-name 0 ,tag-name)
  142.                                ,structure-name))
  143. ;;;                           (define (,predicate-name object)
  144. ;;;                             (and (vector? object)
  145. ;;;                                  (not (zero? (vector-size object)))
  146. ;;;                                  (eq? ,tag-name (vector-ref object 0))))
  147.                            ,@(slot-loop '() slot-names 1)
  148.                            ,@(selector-loop '() selector-names 1))))))))
  149.  
  150. (macro define-command
  151.   (lambda (e)
  152.     (let ((bvl (cadr e)) (description (caddr e)) (body (cdddr e)))
  153.          (let ((name (car bvl))
  154.                (arg-names
  155.                 (mapcar (lambda (arg)
  156.                           (if (pair? arg) (car arg) arg))
  157.                         (cdr bvl)))
  158.                (arg-inits
  159.                 (mapcar (lambda (arg)
  160.                           (if (pair? arg) (cadr arg) #F))
  161.                         (cdr bvl))))
  162.               (let ((procedure-name
  163.                      (string->symbol
  164.                       (string-append (canonicalize-name-string name)
  165.                                      "-COMMAND"))))
  166.                    `(begin
  167.                       (define (,procedure-name ,@arg-names)
  168.                         ,@(map2 (lambda (arg-name arg-init)
  169.                                   `(if (not ,arg-name)
  170.                                        (set! ,arg-name ,arg-init)))
  171.                                 arg-names arg-inits)
  172.                         ,@body)
  173.                       (make-command ,name ,description ,procedure-name)))))))
  174.  
  175. (define canonicalize-name-string
  176.   (lambda (name)
  177.     (let ((name (string-uppercase name)))
  178.      (string-replace! name #\Space #\-)
  179.          name)))
  180.  
  181.  
  182.  
  183.