diff options
Diffstat (limited to 'module/srfi/srfi-9/gnu.scm')
-rw-r--r-- | module/srfi/srfi-9/gnu.scm | 168 |
1 files changed, 168 insertions, 0 deletions
diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm new file mode 100644 index 000000000..219bcdebb --- /dev/null +++ b/module/srfi/srfi-9/gnu.scm @@ -0,0 +1,168 @@ +;;; Extensions to SRFI-9 + +;; Copyright (C) 2010, 2012 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 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 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: + +;; Extensions to SRFI-9. Fully documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-1) + #:use-module (system base ck) + #:export (set-record-type-printer! + define-immutable-record-type + set-field + set-fields)) + +(define (set-record-type-printer! type proc) + "Set PROC as the custom printer for TYPE." + (struct-set! type vtable-index-printer proc)) + +(define-syntax-rule (define-immutable-record-type name ctor pred fields ...) + ((@@ (srfi srfi-9) %define-record-type) + #t (define-immutable-record-type name ctor pred fields ...) + name ctor pred fields ...)) + +(define-syntax-rule (set-field s (getter ...) expr) + (%set-fields #t (set-field s (getter ...) expr) () + s ((getter ...) expr))) + +(define-syntax-rule (set-fields s . rest) + (%set-fields #t (set-fields s . rest) () + s . rest)) + +;; +;; collate-set-field-specs is a helper for %set-fields +;; thats combines all specs with the same head together. +;; +;; For example: +;; +;; SPECS: (((a b c) expr1) +;; ((a d) expr2) +;; ((b c) expr3) +;; ((c) expr4)) +;; +;; RESULT: ((a ((b c) expr1) +;; ((d) expr2)) +;; (b ((c) expr3)) +;; (c (() expr4))) +;; +(define (collate-set-field-specs specs) + (define (insert head tail expr result) + (cond ((find (lambda (tree) + (free-identifier=? head (car tree))) + result) + => (lambda (tree) + `((,head (,tail ,expr) + ,@(cdr tree)) + ,@(delq tree result)))) + (else `((,head (,tail ,expr)) + ,@result)))) + (with-syntax (((((head . tail) expr) ...) specs)) + (fold insert '() #'(head ...) #'(tail ...) #'(expr ...)))) + +(define-syntax unknown-getter + (lambda (x) + (syntax-case x () + ((_ orig-form getter) + (syntax-violation 'set-fields "unknown getter" #'orig-form #'getter))))) + +(define-syntax c-list + (lambda (x) + (syntax-case x (quote) + ((_ s 'v ...) + #'(ck s '(v ...)))))) + +(define-syntax c-same-type-check + (lambda (x) + (syntax-case x (quote) + ((_ s 'orig-form '(path ...) + '(getter0 getter ...) + '(type0 type ...) + 'on-success) + (every (lambda (t g) + (or (free-identifier=? t #'type0) + (syntax-violation + 'set-fields + (format #f + "\ +field paths ~a and ~a require one object to belong to two different record types (~a and ~a)" + (syntax->datum #`(path ... #,g)) + (syntax->datum #'(path ... getter0)) + (syntax->datum t) + (syntax->datum #'type0)) + #'orig-form))) + #'(type ...) + #'(getter ...)) + #'(ck s 'on-success))))) + +(define-syntax %set-fields + (lambda (x) + (with-syntax ((getter-type #'(@@ (srfi srfi-9) getter-type)) + (getter-index #'(@@ (srfi srfi-9) getter-index)) + (getter-copier #'(@@ (srfi srfi-9) getter-copier))) + (syntax-case x () + ((_ check? orig-form (path-so-far ...) + s) + #'s) + ((_ check? orig-form (path-so-far ...) + s (() e)) + #'e) + ((_ check? orig-form (path-so-far ...) + struct-expr ((head . tail) expr) ...) + (let ((collated-specs (collate-set-field-specs + #'(((head . tail) expr) ...)))) + (with-syntax (((getter0 getter ...) + (map car collated-specs))) + (with-syntax ((err #'(unknown-getter + orig-form getter0))) + #`(ck + () + (c-same-type-check + 'orig-form + '(path-so-far ...) + '(getter0 getter ...) + (c-list (getter-type 'getter0 'err) + (getter-type 'getter 'err) ...) + '(let ((s struct-expr)) + ((ck () (getter-copier 'getter0 'err)) + check? + s + #,@(map (lambda (spec) + (with-syntax (((head (tail expr) ...) spec)) + (with-syntax ((err #'(unknown-getter + orig-form head))) + #'(head (%set-fields + check? + orig-form + (path-so-far ... head) + (struct-ref s (ck () (getter-index + 'head 'err))) + (tail expr) ...))))) + collated-specs))))))))) + ((_ check? orig-form (path-so-far ...) + s (() e) (() e*) ...) + (syntax-violation 'set-fields "duplicate field path" + #'orig-form #'(path-so-far ...))) + ((_ check? orig-form (path-so-far ...) + s ((getter ...) expr) ...) + (syntax-violation 'set-fields "one field path is a prefix of another" + #'orig-form #'(path-so-far ...))) + ((_ check? orig-form . rest) + (syntax-violation 'set-fields "invalid syntax" #'orig-form)))))) |