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

Last change on this file since 10987 was 9512, checked in by Kon Lovett, 13 years ago

Rmvd dep procs. Updated doc.

File size: 2.4 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 ',t
14                               ,@(map (lambda (sname)
15                                        (if (memq sname vars)
16                                            sname
17                                            '(##sys#void) ) )
18                                      slotnames) ) )
19       (define (,pred x) (##sys#structure? x ',t))
20       ,@(let loop ([slots slots] [i 1])
21           (if (null? slots)
22               '()
23               (let ([slot (car slots)])
24                 (let ([setters (memq #:record-setters ##sys#features)]
25                       [setr? (pair? (cddr slot))]
26                       [getr `(lambda (x) (##sys#block-ref x ,i) ) ] )
27                   `(,@(if setr?
28                           `((define (,(caddr slot) x y) (##sys#block-set! x ,i y)) )
29                           '() )
30                     (define ,(cadr slot)
31                       ,(if (and setr? setters)
32                            `(getter-with-setter ,getr ,(caddr slot))
33                             getr) )
34                     ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) )
35
36;; SRFI-9 workalike w/o record type checking and inline procedures.
37
38(define-macro (define-inline-unchecked-record-type t conser pred . slots)
39  (let ([vars (cdr conser)]
40        [slotnames (map car slots)] )
41    `(begin
42       (define-inline ,conser
43         (##sys#make-structure ',t
44                               ,@(map (lambda (sname)
45                                        (if (memq sname vars)
46                                            sname
47                                            '(##sys#void) ) )
48                                      slotnames) ) )
49       (define-inline (,pred x) (##sys#structure? x ',t))
50       ,@(let loop ([slots slots] [i 1])
51           (if (null? slots)
52               '()
53               (let ([slot (car slots)])
54                 `(,@(if (pair? (cddr slot))
55                         `((define-inline (,(caddr slot) x y) (##sys#block-set! x ,i y)) )
56                          '() )
57                   (define-inline (,(cadr slot) x) (##sys#block-ref x ,i) )
58                   ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.