source: project/release/3/misc-extn/trunk/misc-extn-record.scm @ 7388

Last change on this file since 7388 was 5437, checked in by Kon Lovett, 14 years ago

Release 3.0, where misc-extn.scm is rmvd & macros split into sep files.

File size: 2.2 KB
Line 
1;;;; misc-extn-record.scm
2;;;; Kon Lovett, Jul '07
3
4;;; Records
5
6;; SRFI-9 workalike w/o record type checking.
7
8(define-macro (define-unchecked-record-type t conser pred . slots)
9  (let ([vars (cdr conser)]
10        [slotnames (map car slots)] )
11    `(begin
12       (define ,conser
13         (##sys#make-structure
14           ',t
15           ,@(map
16               (lambda (sname)
17                 (if (memq sname vars)
18                   sname
19                   '(##sys#void) ) )
20               slotnames) ) )
21       (define (,pred x) (##sys#structure? x ',t))
22       ,@(let loop ([slots slots] [i 1])
23           (if (null? slots)
24             '()
25             (let ([slot (car slots)])
26               (let ([setters (memq #:record-setters ##sys#features)]
27                     [setr? (pair? (cddr slot))]
28                     [getr `(lambda (x) (##sys#block-ref x ,i) ) ] )
29                 `(,@(if setr?
30                       `((define (,(caddr slot) x y)
31                           (##sys#block-set! x ,i y)) )
32                       '() )
33                   (define ,(cadr slot)
34                     ,(if (and setr? setters)
35                        `(getter-with-setter ,getr ,(caddr slot))
36                         getr) )
37                   ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) )
38
39;; SRFI-9 workalike w/o record type checking and inline procedures.
40
41(define-macro (define-inline-unchecked-record-type t conser pred . slots)
42  (let ([vars (cdr conser)]
43        [slotnames (map car slots)] )
44    `(begin
45       (define-inline ,conser
46         (##sys#make-structure
47           ',t
48           ,@(map
49               (lambda (sname)
50                 (if (memq sname vars)
51                   sname
52                   '(##sys#void) ) )
53               slotnames) ) )
54       (define-inline (,pred x) (##sys#structure? x ',t))
55       ,@(let loop ([slots slots] [i 1])
56           (if (null? slots)
57             '()
58             (let ([slot (car slots)])
59               `(,@(if (pair? (cddr slot))
60                     `((define-inline (,(caddr slot) x y)
61                       (##sys#block-set! x ,i y)) )
62                      '() )
63                 (define-inline (,(cadr slot) x)
64                   (##sys#block-ref x ,i) )
65                 ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.