summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/ice-9/boot-9.scm36
-rw-r--r--module/srfi/srfi-9.scm32
2 files changed, 36 insertions, 32 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 33aa33382..327e3fa31 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3497,6 +3497,42 @@ module '(ice-9 q) '(make-q q-length))}."
x)))))
+;;; Defining transparently inlinable procedures
+;;;
+
+(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)
+ ;; Use a space in the prefix to avoid potential -Wunused-toplevel
+ ;; warning
+ (define prefix (string->symbol "% "))
+ (define (make-procedure-name name)
+ (datum->syntax name
+ (symbol-append prefix (syntax->datum name)
+ '-procedure)))
+
+ (syntax-case x ()
+ ((_ (name formals ...) body ...)
+ (identifier? #'name)
+ (with-syntax ((proc-name (make-procedure-name #'name))
+ ((args ...) (generate-temporaries #'(formals ...))))
+ #`(begin
+ (define (proc-name formals ...)
+ body ...)
+ (define-syntax name
+ (lambda (x)
+ (syntax-case x ()
+ ((_ args ...)
+ #'((lambda (formals ...)
+ body ...)
+ args ...))
+ (_
+ (identifier? x)
+ #'proc-name))))))))))
+
+
(define using-readline?
(let ((using-readline? (make-fluid)))
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index f9449a66f..ad9e95de1 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -64,38 +64,6 @@
(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)
- ;; Use a space in the prefix to avoid potential -Wunused-toplevel
- ;; warning
- (define prefix (string->symbol "% "))
- (define (make-procedure-name name)
- (datum->syntax name
- (symbol-append prefix (syntax->datum name)
- '-procedure)))
-
- (syntax-case x ()
- ((_ (name formals ...) body ...)
- (identifier? #'name)
- (with-syntax ((proc-name (make-procedure-name #'name))
- ((args ...) (generate-temporaries #'(formals ...))))
- #`(begin
- (define (proc-name formals ...)
- body ...)
- (define-syntax name
- (lambda (x)
- (syntax-case x ()
- ((_ args ...)
- #'((lambda (formals ...)
- body ...)
- args ...))
- (_
- (identifier? x)
- #'proc-name))))))))))
-
(define-syntax define-record-type
(lambda (x)
(define (field-identifiers field-specs)