/usr/lib/define-structure.scm is in scheme9 2013.11.26-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | ; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010,2012
; Placed in the Public Domain
;
; (define-structure <name> <slot> ...) ==> unspecific
;
; DEFINE-STRUCTURE creates a new type, which is a sub-type of the vector,
; and defines a set of procedures for creating objects of the new type,
; accessing its slots, and checking for its type.
;
; <Name> is the name of the new type. Each <slot> defines a slot of the
; new type. It must be have one of the following forms:
;
; <slot-name>
; (<slot-name>)
; (<slot-name> <initial-value>)
;
; <Slot-name> must be a symbol and <initial-value> may be any value.
; When an <initial-value> is specified, the corresponding slot will
; be filled with that value whenever a new instance of the structure
; is created. When the value is omitted, it defaults to an unspecific
; value. <Slot-name> is equal to (<slot-name>).
;
; (define-structure <type> <slot-1> ... <slot-N>) will expand to
; definitions of the following procedures:
;
; (make-<type> object ...) creates a new object of the type <type> and
; initializes its slots with the values specified in DEFINE-STRUCTURE.
; When some OBJECTs are given, they will replace the default values of
; the first slots of the new <type> object. The number of OBJECTs
; passed to MAKE-<TYPE> must not be larger than the number of slots
; of <type>.
;
; (<type>? x) is a predicate checking whether X has the type <type>.
;
; (<type>-assert caller object) asserts that OBJECT is of the type
; <type>. When the assertion holds, it returns an unspecific value.
; Otherwise, it prints an error message. CALLER is a symbol that
; will be reported as the source of the error (typically the
; procedure calling <type>-assert).
;
; (<type>-copy object) creates an exact (shallow) copy an object of
; the given type and returns it.
;
; (<type>-<slot-1> x) evaluates to the value stored in slot <slot-1>
; of X. When X is not of the type <type>, an error will be signalled.
; (<type>-<slot-N> x) does the same, but accesses <slot-N>.
;
; (<type>-set-<slot-1>! x v) changes the value stored in slot <slot-1>
; of X to V. When X is not of the type <type>, an error will be signalled.
; (<type>-set-<slot-N>! x v) does the same, but changes <slot-N>.
;
; Example: (begin
; (define-structure point (x 0) (y 0) (color #f))
; (let ((p (make-point)))
; (point-set-color! p 'yellow)
; (list (point? p)
; (point-color p)))) ==> (#t yellow)
(load-from-library "iota.scm")
(load-from-library "subvector.scm")
(load-from-library "duplicates.scm")
(define-syntax (define-structure name . slots)
(if (not (symbol? name))
(error "define-structure: expected name, got" name))
(let* ((make-slot
(lambda (x)
(cond ((symbol? x)
(list x #f))
((and (pair? x)
(symbol? (car x))
(null? (cdr x)))
(list (car x) #f))
((and (pair? x)
(symbol? (car x))
(pair? (cdr x))
(null? (cddr x)))
x)
(else
(error "define-structure: expected slot, got" x)))))
(slots (map make-slot slots))
(dupes (dupq (map car slots)))
(symbol-append
(lambda x
(string->symbol
(apply string-append (map symbol->string x)))))
(slot-defs
(map cons
(map car slots)
(iota (length slots))))
(def-tag
`(define ,(symbol-append '* name '-type-tag*) (list ',name)))
(def-maker
(let ((args (gensym))
(vec (gensym))
(isym (gensym))
(asym (gensym))
(m-name (symbol-append 'make- name)))
`(define (,m-name . ,args)
(if (> (length ,args) ,(length slots))
(error (string-append
(symbol->string ',m-name)
": too many arguments")
,args))
(let ((,vec (vector ,(symbol-append '* name '-type-tag*)
,@(map cadr slots))))
(do ((,isym 1 (+ 1 ,isym))
(,asym ,args (cdr ,asym)))
((null? ,asym))
(vector-set! ,vec ,isym (car ,asym)))
,vec))))
(def-predicate
(let ((p-name (symbol-append name '?)))
`(define ,p-name
(let ((tag ,(symbol-append '* name '-type-tag*)))
(lambda (x)
(and (vector? x)
(positive? (vector-length x))
(eq? tag (vector-ref x 0))))))))
(def-assert
`(define (,(symbol-append name '-assert) who x)
(if (not (,(symbol-append name '?) x))
(error (string-append (symbol->string who)
": expected type <"
(symbol->string ',name)
">, got")
x))))
(def-copier
(let ((c-name (symbol-append name '-copy))
(a-name (symbol-append name '-assert)))
`(define ,c-name
(let ((,a-name ,a-name))
(lambda (x)
(,a-name ',c-name x)
(vector-copy x))))))
(def-getters
(map (lambda (s)
(let ((g-name (symbol-append name '- (car s)))
(a-name (symbol-append name '-assert)))
`(define ,g-name
(let ((,a-name ,a-name))
(lambda (x)
(,a-name ',g-name x)
(vector-ref x ,(cdr s)))))))
slot-defs))
(def-setters
(map (lambda (s)
(let ((s-name (symbol-append name '-set- (car s) '!))
(a-name (symbol-append name '-assert)))
`(define ,s-name
(let ((,a-name ,a-name))
(lambda (x v)
(,a-name ',s-name x)
(vector-set! x ,(cdr s) v))))))
slot-defs)))
(if (not (null? dupes))
(error "define-structure: duplicate slot names" dupes))
`(begin ,def-tag
,def-predicate
,def-assert
,def-maker
,def-copier
,@def-getters
,@def-setters)))
|