home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / struct < prev    next >
Text File  |  1994-08-09  |  4KB  |  139 lines
  1. ;;; "struct.scm": defmacros for RECORDS
  2. ;;; Copyright 1992 Jeff Alexander, Shinnder Lee, and Lewis Patterson
  3.  
  4. ;;; Defmacros which implement RECORDS from the book:
  5. ;;; "Essentials of Programming Languages" by Daniel P. Friedman,
  6. ;;;   M. Wand and C.T. Haynes.
  7.  
  8. ;;; jaffer@ai.mit.edu, Feb 1993 ported to SLIB.
  9.  
  10. (require 'common-list-functions)
  11.  
  12. (defmacro define-record args
  13.   (check-define-record-syntax args
  14.     (lambda (name make-name name? field-accessors)
  15.       (letrec
  16.     ((make-fields
  17.        (lambda (field-accessors i)
  18.          (if (null? field-accessors)
  19.            '()
  20.            (cons
  21.          `(define ,(car field-accessors)
  22.             (lambda (obj)
  23.               (if (,name? obj)
  24.             (vector-ref obj ,i)
  25.             (slib:error ',(car field-accessors)
  26.               ": bad record" obj))))
  27.          (make-fields (cdr field-accessors) (+ i 1)))))))
  28.     `(begin
  29.        ,@(make-fields field-accessors 1)
  30.        (define ,name?
  31.          (lambda (obj)
  32.            (and (vector? obj)
  33.          (= (vector-length obj) ,(+ 1 (length field-accessors)))
  34.          (eq? (vector-ref obj 0) ',name))))
  35.        (define ,make-name
  36.          (lambda ,field-accessors
  37.            (vector ',name ,@field-accessors))))))))
  38.  
  39. (defmacro variant-case args
  40.   (check-variant-case-syntax args
  41.     (lambda (exp clauses)
  42.       (let ((var (gentemp)))
  43.     (let
  44.       ((make-clause
  45.          (lambda (clause)
  46.            (if (eq? (car clause) 'else)
  47.          `(#t ,@(cdr clause))
  48.          `((,(car clause) ,var)
  49.            (let ,(map (lambda (field)
  50.                 `(,(car field) (,(cdr field) ,var)))
  51.                (cadr clause))
  52.              ,@(cddr clause)))))))
  53.       `(let ((,var ,exp))
  54.          (cond ,@(map make-clause clauses))))))))
  55.  
  56. ;;; syntax checkers
  57.  
  58. ;;; name make-name name? field-accessors
  59.  
  60. (define check-define-record-syntax
  61.   (lambda (x k)
  62.       (cond
  63.     ((and (list? x)
  64.        (= (length x) 2)
  65.        (symbol? (car x))
  66.        (list? (cadr x))
  67.        (comlist:every symbol? (cadr x))
  68.        (not (struct:duplicate-fields? (cadr x))))
  69.      (let ((name (symbol->string (car x))))
  70.        (let ((make-name (string->symbol
  71.                   (string-append (symbol->string 'make-) name)))
  72.          (name? (string->symbol (string-append name "?")))
  73.          (field-accessors
  74.            (map
  75.              (lambda (field)
  76.                (string->symbol
  77.              (string-append name "->" (symbol->string field))))
  78.              (cadr x))))
  79.          (k (car x) make-name name? field-accessors))))
  80.     (else (slib:error "define-record: invalid syntax" x)))))
  81.        
  82. (define check-variant-case-syntax
  83.   (let
  84.     ((make-clause
  85.        (lambda (clause)
  86.      (if (eq? (car clause) 'else) 
  87.        clause
  88.        (let ((name (symbol->string (car clause))))
  89.          (let ((name? (string->symbol (string-append name "?")))
  90.            (fields
  91.              (map
  92.                (lambda (field)
  93.              (cons field
  94.                (string->symbol
  95.                  (string-append name "->"
  96.                    (symbol->string field)))))
  97.                (cadr clause))))
  98.            (cons name? (cons fields (cddr clause)))))))))
  99.     (lambda (args k)
  100.       (if (and (list? args)
  101.         (<= 2 (length args))
  102.         (struct:clauses? (cdr args)))
  103.     (k (car args) (map make-clause (cdr args)))
  104.     (slib:error "variant-case: invalid syntax" args)))))
  105.  
  106. (define struct:duplicate-fields?
  107.   (lambda (fields)
  108.     (cond
  109.       ((null? fields) #f)
  110.       ((memq (car fields) (cdr fields)) #t)
  111.       (else (struct:duplicate-fields? (cdr fields))))))
  112.  
  113. (define struct:clauses?
  114.   (let
  115.     ((clause?
  116.        (lambda (clause)
  117.      (and (list? clause)
  118.           (not (null? clause))
  119.           (cond
  120.         ((eq? (car clause) 'else)
  121.          (not (null? (cdr clause))))
  122.         (else (and (symbol? (car clause))
  123.                (not (null? (cdr clause)))
  124.                (list? (cadr clause))
  125.                (comlist:every symbol? (cadr clause))
  126.                (not (struct:duplicate-fields? (cadr clause)))
  127.                (not (null? (cddr clause))))))))))
  128.     (letrec
  129.       ((struct:duplicate-tags?
  130.      (lambda (tags)
  131.        (cond
  132.          ((null? tags) #f)
  133.          ((eq? (car tags) 'else) (not (null? (cdr tags))))
  134.          ((memq (car tags) (cdr tags)) #t)
  135.          (else (struct:duplicate-tags? (cdr tags)))))))
  136.       (lambda (clauses)
  137.     (and (comlist:every clause? clauses)
  138.          (not (struct:duplicate-tags? (map car clauses))))))))
  139.