defdata.scm 5.0 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
  3. ; Macros for defining data types.
  4. ; An ugly and unsafe macro for defining VM data structures.
  5. ;
  6. ; (DEFINE-PRIMITIVE-DATA-TYPE <name> <type> <immutable?> <constructor-name>
  7. ; <slot>*)
  8. ; <slot> ::= (<accessor-name>) | (<accessor-name> <modifier-name>)
  9. ;
  10. ; (define-primitive-data-type pair N #f cons (car set-car!) (cdr))
  11. ; =>
  12. ; (begin
  13. ; (define (cons a b) (d-vector N ...))
  14. ; (define pair? (stob-predicate ...))
  15. ; (define pair-size 3)
  16. ; (define (car x) (d-vector-ref x 0))
  17. ; (define (set-car! x val) (d-vector-set! x 0 val))
  18. ; (define (cdr x) (d-vector-ref x 1))
  19. (define-syntax define-primitive-data-type
  20. (lambda (exp rename compare)
  21. (destructure (((d-p-d-t name type immutable? make . body) exp))
  22. (define (concatenate-symbol . syms)
  23. (string->symbol (apply string-append (map symbol->string syms))))
  24. (let* ((pred (concatenate-symbol name '?))
  25. (size (concatenate-symbol name '- 'size))
  26. (shorten (lambda (l1 l2) (map (lambda (x1 x2) x2 x1) l1 l2)))
  27. (vars (shorten `(a b c d e f g h i j) body)))
  28. `(begin ,@(if make
  29. `((define ,make
  30. (let ((type (enum stob ,type)))
  31. (lambda (,@vars key)
  32. ,(if immutable?
  33. `(immutable-d-vector type key ,@vars)
  34. `(d-vector type key ,@vars))))))
  35. '())
  36. (define ,pred (stob-predicate (enum stob ,type)))
  37. (define ,size (+ ,(length body) stob-overhead))
  38. ,@(do ((s body (cdr s))
  39. (i 0 (+ i 1))
  40. (d '() (let* ((slot (car s))
  41. (d (cons `(define (,(car slot) x)
  42. (d-vector-ref x ,i))
  43. d)))
  44. (if (null? (cdr slot))
  45. d
  46. (cons `(define (,(cadr slot) x val)
  47. (d-vector-set! x ,i val))
  48. d)))))
  49. ((null? s) (reverse d))))))))
  50. ; This is a front for DEFINE-PRIMITIVE-DATA-TYPE that gets the names from
  51. ; STOB-DATA (which is defined in arch.scm). This ensures that the run-time
  52. ; code, the VM, and the linker agree on what these structures look like.
  53. ;
  54. ; SCHEME? is #T if the data structure is a Scheme structure, in which case
  55. ; the names defined by the form all have VM- prepended.
  56. (define-syntax define-shared-primitive-data-type
  57. (lambda (exp rename compare)
  58. (let* ((name (cadr exp))
  59. (scheme? (if (null? (cddr exp)) #f (car (cddr exp))))
  60. (immutable? (if (or (null? (cddr exp))
  61. (null? (cdddr exp)))
  62. #f
  63. (cadr (cddr exp))))
  64. (rest (if (or (null? (cddr exp))
  65. (null? (cdddr exp)))
  66. '()
  67. (cddddr exp)))
  68. (extra-maker (if (null? rest) #f (car rest)))
  69. (extra-setters (if (or (null? rest)
  70. (null? (cdr rest)))
  71. '()
  72. (cadr rest)))
  73. (extra-fields (if (or (null? rest)
  74. (null? (cdr rest)))
  75. '()
  76. (cddr rest))))
  77. (define (concatenate-symbol . syms)
  78. (string->symbol (apply string-append (map symbol->string syms))))
  79. (let ((data (cddr (assq name stob-data)))
  80. (fixup (lambda (n)
  81. (if scheme? (concatenate-symbol 'vm- n) n))))
  82. `(define-primitive-data-type
  83. ,(fixup name)
  84. ,name
  85. ,immutable?
  86. ,(fixup (if (car data) (car data) extra-maker))
  87. . ,(map (lambda (p)
  88. (cons (fixup (car p))
  89. (cond ((and (not (null? (cdr p)))
  90. (cadr p))
  91. (list (fixup (cadr p))))
  92. ((assq (car p) extra-setters)
  93. => cdr)
  94. (else '()))))
  95. (append (cdr data) extra-fields)))))))
  96. ; A d-vector macro version of the VECTOR procedure.
  97. ; This is only used in the expansion of DEFINE-PRIMITIVE-DATA-TYPE.
  98. (define-syntax d-vector
  99. (lambda (exp rename compare)
  100. (destructure (((d-v type key . args) exp))
  101. `(let ((v (make-d-vector ,type ,(length args) key)))
  102. ,@(do ((a args (cdr a))
  103. (i 0 (+ i 1))
  104. (z '() (cons `(d-vector-init! v ,i ,(car a)) z)))
  105. ((null? a) (reverse z)))
  106. v))))
  107. (define-syntax immutable-d-vector
  108. (syntax-rules ()
  109. ((immutable-d-vector stuff ...)
  110. (let ((vec (d-vector stuff ...)))
  111. (make-immutable! vec)
  112. vec))))
  113. ; A simpler macro for defining types of vectors. Again SCHEME? being #T
  114. ; causes VM- to be prepended to the defined names.
  115. (define-syntax define-vector-data-type
  116. (lambda (exp rename compare)
  117. (let ((name (cadr exp))
  118. (scheme? (cddr exp)))
  119. (define (concatenate-symbol . syms)
  120. (string->symbol (apply string-append (map symbol->string syms))))
  121. (let* ((type `(enum stob ,name))
  122. (fix (if (not (null? scheme?))
  123. 'vm-
  124. (string->symbol "")))
  125. (pred (concatenate-symbol fix name '?))
  126. (make (concatenate-symbol fix 'make- name))
  127. (size (concatenate-symbol fix name '- 'size))
  128. (length (concatenate-symbol fix name '- 'length))
  129. (ref (concatenate-symbol fix name '- 'ref))
  130. (set (concatenate-symbol fix name '- 'set!)))
  131. `(begin (define ,make (stob-maker ,type make-d-vector))
  132. (define ,pred (stob-predicate ,type))
  133. (define (,size len) (+ len stob-overhead))
  134. (define ,length d-vector-length)
  135. (define ,ref d-vector-ref)
  136. (define ,set d-vector-set!))))))