home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / structure < prev    next >
Text File  |  1994-05-25  |  3KB  |  69 lines
  1. ;;; "structure.scm" syntax-case structure macros
  2. ;;; Written by Robert Hieb & Kent Dybvig
  3.  
  4. ;;; This file was munged by a simple minded sed script since it left
  5. ;;; its original authors' hands.  See syncase.sh for the horrid details.
  6.  
  7. ;;; structure.ss
  8. ;;; Robert Hieb & Kent Dybvig
  9. ;;; 92/06/18
  10.  
  11. (define-syntax define-structure
  12.    (lambda (x)
  13.       (define construct-name
  14.          (lambda (template-identifier . args)
  15.             (implicit-identifier
  16.                template-identifier
  17.                (string->symbol
  18.                   (apply string-append
  19.                          (map (lambda (x)
  20.                                  (if (string? x)
  21.                                      x
  22.                                      (symbol->string (syntax-object->datum x))))
  23.                               args))))))
  24.       (syntax-case x ()
  25.          ((_ (name id1 ...))
  26.           (syntax (define-structure (name id1 ...) ())))
  27.          ((_ (name id1 ...) ((id2 init) ...))
  28.           (with-syntax
  29.              ((constructor (construct-name (syntax name) "make-" (syntax name)))
  30.               (predicate (construct-name (syntax name) (syntax name) "?"))
  31.               ((access ...)
  32.                (map (lambda (x) (construct-name x (syntax name) "-" x))
  33.                     (syntax (id1 ... id2 ...))))
  34.               ((assign ...)
  35.                (map (lambda (x)
  36.                        (construct-name x "set-" (syntax name) "-" x "!"))
  37.                     (syntax (id1 ... id2 ...))))
  38.               (structure-length
  39.                (+ (length (syntax (id1 ... id2 ...))) 1))
  40.               ((index ...)
  41.                (let f ((i 1) (ids (syntax (id1 ... id2 ...))))
  42.                   (if (null? ids)
  43.                       '()
  44.                       (cons i (f (+ i 1) (cdr ids)))))))
  45.              (syntax (begin
  46.                         (define constructor
  47.                            (lambda (id1 ...)
  48.                               (let* ((id2 init) ...)
  49.                                  (vector 'name id1 ... id2 ...))))
  50.                         (define predicate
  51.                            (lambda (x)
  52.                               (and (vector? x)
  53.                                    (= (vector-length x) structure-length)
  54.                                    (eq? (vector-ref x 0) 'name))))
  55.                         (define access
  56.                            (lambda (x)
  57.                               (vector-ref x index)))
  58.                         ...
  59.                         ; define macro accessors this way:
  60.                         ; (define-syntax access
  61.                         ;       (syntax-case x ()
  62.                         ;          ((_ x)
  63.                         ;           (syntax (vector-ref x index))))))
  64.                         ; ...
  65.                         (define assign
  66.                            (lambda (x update)
  67.                               (vector-set! x index update)))
  68.                         ...)))))))
  69.