;;; srfi-9.scm --- define-record-type
-;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; Code:
(define-module (srfi srfi-9)
- :export-syntax (define-record-type))
+ #:use-module (srfi srfi-1)
+ #:export (define-record-type))
(cond-expand-provide (current-module) '(srfi-9))
-(define-macro (define-record-type type-name constructor/field-tag
- predicate-name . field-specs)
- `(begin
- (define ,type-name
- (make-record-type ',type-name ',(map car field-specs)))
- (define ,(car constructor/field-tag)
- (record-constructor ,type-name ',(cdr constructor/field-tag)))
- (define ,predicate-name
- (record-predicate ,type-name))
- ,@(map
- (lambda (spec)
- (cond
- ((= (length spec) 2)
- `(define ,(cadr spec)
- (record-accessor ,type-name ',(car spec))))
- ((= (length spec) 3)
- `(begin
- (define ,(cadr spec)
- (record-accessor ,type-name ',(car spec)))
- (define ,(caddr spec)
- (record-modifier ,type-name ',(car spec)))))
- (else
- (error "invalid field spec " spec))))
- field-specs)))
+(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 ...))
+ (_
+ (identifier? x)
+ #'proc-name))))))))))
+
+(define-syntax define-record-type
+ (lambda (x)
+ (define (field-identifiers field-specs)
+ (syntax-case field-specs ()
+ ((field-spec)
+ (syntax-case #'field-spec ()
+ ((name accessor) #'(name))
+ ((name accessor modifier) #'(name))))
+ ((field-spec rest ...)
+ (append (field-identifiers #'(field-spec))
+ (field-identifiers #'(rest ...))))))
+
+ (define (field-indices fields)
+ (fold (lambda (field result)
+ (let ((i (if (null? result)
+ 0
+ (+ 1 (cdar result)))))
+ (alist-cons field i result)))
+ '()
+ fields))
+
+ (define (constructor type-name constructor-spec indices)
+ (syntax-case constructor-spec ()
+ ((ctor field ...)
+ (let ((field-count (length indices))
+ (ctor-args (map (lambda (field)
+ (cons (syntax->datum field) field))
+ #'(field ...))))
+ #`(define-inlinable #,constructor-spec
+ (make-struct #,type-name 0
+ #,@(unfold
+ (lambda (field-num)
+ (>= field-num field-count))
+ (lambda (field-num)
+ (let* ((name
+ (car (find (lambda (f+i)
+ (= (cdr f+i) field-num))
+ indices)))
+ (arg (assq name ctor-args)))
+ (if (pair? arg)
+ (cdr arg)
+ #'#f)))
+ 1+
+ 0)))))))
+
+ (define (accessors type-name field-specs indices)
+ (syntax-case field-specs ()
+ ((field-spec)
+ (syntax-case #'field-spec ()
+ ((name accessor)
+ (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
+ #`((define-inlinable (accessor s)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-ref s index)
+ (throw 'wrong-type-arg 'accessor
+ "Wrong type argument: ~S" (list s)
+ (list s)))))))
+ ((name accessor modifier)
+ (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
+ #`(#,@(accessors type-name #'((name accessor)) indices)
+ (define-inlinable (modifier s val)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-set! s index val)
+ (throw 'wrong-type-arg 'modifier
+ "Wrong type argument: ~S" (list s)
+ (list s)))))))))
+ ((field-spec rest ...)
+ #`(#,@(accessors type-name #'(field-spec) indices)
+ #,@(accessors type-name #'(rest ...) indices)))))
+
+ (syntax-case x ()
+ ((_ type-name constructor-spec predicate-name field-spec ...)
+ (let* ((fields (field-identifiers #'(field-spec ...)))
+ (field-count (length fields))
+ (layout (string-concatenate (make-list field-count "pw")))
+ (indices (field-indices (map syntax->datum fields))))
+ #`(begin
+ (define type-name
+ (make-vtable #,layout
+ (lambda (obj port)
+ (format port "#<~A" 'type-name)
+ #,@(map (lambda (field)
+ (let* ((f (syntax->datum field))
+ (i (assoc-ref indices f)))
+ #`(format port " ~A: ~S" '#,field
+ (struct-ref obj #,i))))
+ fields)
+ (format port ">"))))
+ (define-inlinable (predicate-name obj)
+ (and (struct? obj)
+ (eq? (struct-vtable obj) type-name)))
+
+ #,(constructor #'type-name #'constructor-spec indices)
+
+ #,@(accessors #'type-name #'(field-spec ...) indices)))))))
;;; srfi-9.scm ends here
HCoop / bpt / guile.git / blobdiff