home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / DEFRECOR.SCM < prev    next >
Text File  |  1992-06-17  |  3KB  |  94 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4.  
  5. ; Syntax for defining record types
  6.  
  7.  
  8. ; (define-record-type name constructor-fields other-fields)
  9.  
  10. ; Constructor-arguments fields are either <name> or (<name>), the second
  11. ; indicating a field whose value can be modified.
  12. ; Other-fields are one of:
  13. ;  (<name> <expression>) = modifiable field with the given value.
  14. ;  <name>                = modifiable field with no initial value.
  15.  
  16. ;(define-record-type job
  17. ;  ((thunk)
  18. ;   (dynamic-env)
  19. ;   number
  20. ;   inferior-lock
  21. ;   )
  22. ;  ((on-queue  #f)
  23. ;   (superior  #f)
  24. ;   (inferiors '())
  25. ;   (condition #f)
  26. ;   ))
  27.  
  28. (define-syntax define-record-type
  29.  
  30.   (let ()
  31.  
  32.     (define s->s symbol->string)
  33.     (define s-conc (lambda args (string->symbol (apply string-append args))))
  34.     (define spec-name (lambda (s) (if (pair? s) (car s) s)))
  35.     (define (filter pred lst)
  36.       (if (null? lst)
  37.       '()
  38.       (if (pred (car lst))
  39.           (cons (car lst) (filter pred (cdr lst)))
  40.           (filter pred (cdr lst)))))
  41.  
  42.     (lambda (form rename compare)
  43.       (let* ((name (cadr form))
  44.          (arg-fields (caddr form))
  45.          (other-fields (cadddr form))
  46.          (init-fields (filter pair? other-fields))
  47.  
  48.          (field-name (lambda (field-name)
  49.                (s-conc (s->s name) "-" (s->s field-name))))
  50.          (set-name (lambda (field-name)
  51.              (s-conc "set-" (s->s name)
  52.                  "-" (s->s field-name) "!")))
  53.          (pred-name (s-conc (s->s name) "?"))
  54.          (maker-name (s-conc (s->s name) "-maker"))
  55.          (type-name (s-conc "type/" (s->s name)))
  56.  
  57.          (make (rename 'make))
  58.          (%make-record-type   (rename 'make-record-type))
  59.          (%record-constructor (rename 'record-constructor))
  60.          (%record-predicate      (rename 'record-predicate))
  61.          (%record-accessor      (rename 'record-accessor))
  62.          (%record-modifier      (rename 'record-modifier))
  63.          (%unspecified      (rename 'unspecified))
  64.          (%define          (rename 'define))
  65.          (%let          (rename 'let))
  66.          (%lambda          (rename 'lambda))
  67.          (%begin          (rename 'begin)))
  68.     `(,%begin
  69.        (,%define ,type-name
  70.          (,%make-record-type ',name
  71.                  ',(map spec-name
  72.                     (append arg-fields other-fields))))
  73.        (,%define ,maker-name
  74.          (,%let ((,make (,%record-constructor
  75.                  ,type-name
  76.                  ',(map spec-name
  77.                     (append arg-fields init-fields)))))
  78.            (,%lambda ,(map spec-name arg-fields)
  79.          (,make ,@(map spec-name arg-fields)
  80.             ,@(map cadr init-fields)))))
  81.        (,%define ,pred-name (,%record-predicate ,type-name))
  82.        ,@(map (lambda (spec)
  83.             `(,%define ,(field-name (spec-name spec))
  84.                (,%record-accessor ,type-name ',(spec-name spec))))
  85.           (append arg-fields other-fields))
  86.        ,@(map (lambda (spec)
  87.             `(,%define ,(set-name (spec-name spec))
  88.                (,%record-modifier ,type-name ',(spec-name spec))))
  89.           (filter pair? arg-fields))
  90.        ,@(map (lambda (spec)
  91.             `(,%define ,(set-name (spec-name spec))
  92.                (,%record-modifier ,type-name ',(spec-name spec))))
  93.           other-fields))))))
  94.