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

Last change on this file was 12010, checked in by Kon Lovett, 13 years ago

Added "unsafe" record-type.

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