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