File: bummed-jar-defrecord.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (69 lines) | stat: -rw-r--r-- 2,459 bytes parent folder | download
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
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


; Same as jar-defrecord.scm, but field access is "optimized" in a
; brutally unmodular way.  The accessors and modifiers are easily
; recognized as inlinable because instead of being produced by the
; usual record-accessor and record-modifier combinators, they're
; defined directly as procedures that do record-ref and record-set!
; with constant indexes.  There is no check to make sure that the
; record is a record of the correct type.

; Since the record types are not checked at run time, we use LOOPHOLE
; to at least try to get a little bit of compile-time checking.

(define-syntax define-record-type    ;same as in jar-defrecord.scm
  (syntax-rules ()
    ((define-record-type ?id ?type
       (?constructor ?arg ...)
       (?field . ?field-stuff)
       ...)
     (begin (define ?type (make-record-type '?id '(?field ...)))
	    (define-constructor ?constructor ?type (?arg :value) ...)
	    (define-accessors ?type (?field . ?field-stuff) ...)))
    ((define-record-type ?id ?type
       (?constructor ?arg ...)
       ?pred
       ?more ...)
     (begin (define-record-type ?id ?type
	      (?constructor ?arg ...)
	      ?more ...)
	    (define ?pred (record-predicate ?type))))))

(define-syntax define-constructor
  (syntax-rules ()
    ((define-constructor ?constructor ?type (?arg ?arg-type) ...)
     (define ?constructor
       (loophole (proc (?arg-type ...) ?type)
		 (record-constructor ?type '(?arg ...)))))))

(define-syntax define-accessors
  (lambda (e r c)
    (let ((%define-accessor (r 'define-accessor))
	  (%begin (r 'begin))
	  (type (cadr e))
	  (field-specs (cddr e)))
      (do ((i 1 (+ i 1))
	   (field-specs field-specs (cdr field-specs))
	   (ds '()
	       (cons `(,%define-accessor ,type ,i ,@(cdar field-specs))
		     ds)))
	  ((null? field-specs)
	   `(,%begin ,@ds)))))
  (define-accessor begin))

(define-syntax define-accessor
  (syntax-rules ()
    ((define-accessor ?type ?index ?accessor)
     (define ?accessor
       (loophole (proc (?type) :value)
		 (lambda (r)
		   (record-ref (loophole :record r) ?index)))))
    ((define-accessor ?type ?index ?accessor ?modifier)
     (begin (define-accessor ?type ?index ?accessor)
	    (define ?modifier
	      (loophole (proc (?type :value) :unspecific)
			(lambda (r new)
			  (record-set! (loophole :record r) ?index new))))))
    ((define-accessor ?type ?index)
     (begin))))