summaryrefslogtreecommitdiffstats
path: root/structure.scm
diff options
context:
space:
mode:
Diffstat (limited to 'structure.scm')
-rw-r--r--structure.scm80
1 files changed, 80 insertions, 0 deletions
diff --git a/structure.scm b/structure.scm
new file mode 100644
index 0000000..0d379b9
--- /dev/null
+++ b/structure.scm
@@ -0,0 +1,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)))
+ ...)))))))