mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-11 00:00:49 +02:00
80 lines
2.6 KiB
Scheme
80 lines
2.6 KiB
Scheme
;;; "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)))
|
|
...)))))))
|