summaryrefslogtreecommitdiffstats
path: root/structure.scm
blob: 0d379b969994cfca09c12c773462bec274d59bc2 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
;;; "structure.scm" syntax-case structure macros
;;; Copyright (C) 1992 R. Kent Dybvig
;;;
;;; Permission to copy this software, in whole or in part, to use this
;;; software for any lawful purpose, and to redistribute this software
;;; is granted subject to the restriction that all copies made of this
;;; software must include this copyright notice in full.  This software
;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
;;; NATURE WHATSOEVER.

;;; Written by Robert Hieb & Kent Dybvig

;;; This file was munged by a simple minded sed script since it left
;;; its original authors' hands.  See syncase.sh for the horrid details.

;;; structure.ss
;;; Robert Hieb & Kent Dybvig
;;; 92/06/18

(define-syntax define-structure
  (lambda (x)
     (define construct-name
	(lambda (template-identifier . args)
	   (implicit-identifier
	      template-identifier
	      (string->symbol
		 (apply string-append
			(map (lambda (x)
				(if (string? x)
				    x
				    (symbol->string (syntax-object->datum x))))
			     args))))))
     (syntax-case x ()
	((_ (name id1 ...))
	 (syntax (define-structure (name id1 ...) ())))
	((_ (name id1 ...) ((id2 init) ...))
	 (with-syntax
	    ((constructor (construct-name (syntax name) "make-" (syntax name)))
	     (predicate (construct-name (syntax name) (syntax name) "?"))
	     ((access ...)
	      (map (lambda (x) (construct-name x (syntax name) "-" x))
		   (syntax (id1 ... id2 ...))))
	     ((assign ...)
	      (map (lambda (x)
		      (construct-name x "set-" (syntax name) "-" x "!"))
		   (syntax (id1 ... id2 ...))))
	     (structure-length
	      (+ (length (syntax (id1 ... id2 ...))) 1))
	     ((index ...)
	      (let f ((i 1) (ids (syntax (id1 ... id2 ...))))
		 (if (null? ids)
		     '()
		     (cons i (f (+ i 1) (cdr ids)))))))
	    (syntax (begin
		       (define constructor
			  (lambda (id1 ...)
			     (let* ((id2 init) ...)
				(vector 'name id1 ... id2 ...))))
		       (define predicate
			  (lambda (x)
			     (and (vector? x)
				  (= (vector-length x) structure-length)
				  (eq? (vector-ref x 0) 'name))))
		       (define access
			  (lambda (x)
			     (vector-ref x index)))
		       ...
		       ;; define macro accessors this way:
		       ;; (define-syntax access
		       ;;       (syntax-case x ()
		       ;;          ((_ x)
		       ;;           (syntax (vector-ref x index)))))
		       ;; ...
		       (define assign
			  (lambda (x update)
			     (vector-set! x index update)))
		       ...)))))))