mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

SRFI-9: Make accessors inlinable.

Browse source 
* module/srfi/srfi-9.scm (define-inlinable): New macro.
  (define-record-type): Use it.
This commit is contained in:
Ludovic Courtès 2009-12-06 23:15:18 +01:00
parent 09a8dc97db
commit fe258c43a1
1 changed files with 29 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

32
module/srfi/srfi-9.scm
View file

@ -64,6 +64,32 @@
(cond-expand-provide (current-module) '(srfi-9)) (cond-expand-provide (current-module) '(srfi-9))
(define-syntax define-inlinable
;; Define a macro and a procedure such that direct calls are inlined, via
;; the macro expansion, whereas references in non-call contexts refer to
;; the procedure. Inspired by the `define-integrable' macro by Dybvig et al.
(lambda (x)
(define (make-procedure-name name)
(datum->syntax name
(symbol-append '% (syntax->datum name)
'-procedure)))
(syntax-case x ()
((_ (name formals ...) body ...)
(identifier? #'name)
(with-syntax ((proc-name (make-procedure-name #'name)))
#`(begin
(define (proc-name formals ...)
body ...)
proc-name ;; unused
(define-syntax name
(lambda (x)
(syntax-case x ()
((_ formals ...)
#'(begin body ...))
(_
#'proc-name))))))))))
(define-syntax define-record-type (define-syntax define-record-type
(lambda (x) (lambda (x)
(define (field-identifiers field-specs) (define (field-identifiers field-specs)
@ -115,7 +141,7 @@
(syntax-case #'field-spec () (syntax-case #'field-spec ()
((name accessor) ((name accessor)
(with-syntax ((index (assoc-ref indices (syntax->datum #'name)))) (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
#`((define (accessor s) #`((define-inlinable (accessor s)
(if (eq? (struct-vtable s) #,type-name) (if (eq? (struct-vtable s) #,type-name)
(struct-ref s index) (struct-ref s index)
(throw 'wrong-type-arg 'accessor (throw 'wrong-type-arg 'accessor
@ -124,7 +150,7 @@
((name accessor modifier) ((name accessor modifier)
(with-syntax ((index (assoc-ref indices (syntax->datum #'name)))) (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
#`(#,@(accessors type-name #'((name accessor)) indices) #`(#,@(accessors type-name #'((name accessor)) indices)
(define (modifier s val) (define-inlinable (modifier s val)
(if (eq? (struct-vtable s) #,type-name) (if (eq? (struct-vtable s) #,type-name)
(struct-set! s index val) (struct-set! s index val)
(throw 'wrong-type-arg 'modifier (throw 'wrong-type-arg 'modifier
@ -152,7 +178,7 @@
(struct-ref obj #,i)))) (struct-ref obj #,i))))
fields) fields)
(format port ">")))) (format port ">"))))
(define (predicate-name obj) (define-inlinable (predicate-name obj)
(and (struct? obj) (and (struct? obj)
(eq? (struct-vtable obj) type-name))) (eq? (struct-vtable obj) type-name)))