commit d7fda173a20684a5c5f1b8f893d44c784ed07d53
parent dce0e50fe2d3f0472723bf1303d19a8e13cfb347
Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
Date: Fri, 14 Aug 2015 10:20:38 +0200
Make it a library.
Diffstat:
3 files changed, 149 insertions(+), 146 deletions(-)
diff --git a/generic-ref-set.body.scm b/generic-ref-set.body.scm
@@ -0,0 +1,138 @@
+;;; generic-ref-set --- Generic accessor and modifier operators.
+
+;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Helpers
+
+(define-syntax push!
+ (syntax-rules ()
+ ((_ <list-var> <x>)
+ (set! <list-var> (cons <x> <list-var>)))))
+
+(define-syntax alist-add!
+ (syntax-rules ()
+ ((_ <alist-var> <key> <value>)
+ (push! <alist-var> (cons <key> <value>)))))
+
+;;; Main
+
+(define ref
+ (case-lambda
+ ((object field)
+ (let ((getter (lookup-getter object))
+ (sparse? (sparse-type? object)))
+ (if sparse?
+ (let* ((not-found (cons #f #f))
+ (result (getter object field not-found)))
+ (if (eqv? result not-found)
+ (error "Object has no entry for field." object field)
+ result))
+ (getter object field))))
+ ((object field default)
+ (let ((getter (lookup-getter object)))
+ (getter object field default)))))
+
+(define-syntax set!
+ (syntax-rules ()
+ ((set! <place> <expression>)
+ (%set! <place> <expression>))
+ ((set! <object> <field> <value>)
+ (let* ((object <object>)
+ (setter (lookup-setter object)))
+ (setter object <field> <value>)))))
+
+(set! (setter ref) (lambda (object field value) (set! object field value)))
+
+(define (lookup-getter object)
+ (let ((entry (assv (type-of object) getter-table)))
+ (if entry
+ (cdr entry)
+ (error "No generic getter for object's type." object))))
+
+(define (lookup-setter object)
+ (let ((entry (assv (type-of object) setter-table)))
+ (if entry
+ (cdr entry)
+ (error "No generic setter for object's type." object))))
+
+(define (sparse-type? object)
+ (memv (type-of object) sparse-types))
+
+(define (type-of object)
+ (find (lambda (pred) (pred object)) type-list))
+
+(define getter-table
+ (list (cons bytevector? bytevector-u8-ref)
+ (cons hashtable? hashtable-ref)
+ (cons pair? list-ref)
+ (cons string? string-ref)
+ (cons vector? vector-ref)))
+
+(define setter-table
+ (list (cons bytevector? bytevector-u8-set!)
+ (cons hashtable? hashtable-set!)
+ (cons pair? list-set!)
+ (cons string? string-set!)
+ (cons vector? vector-set!)))
+
+(define sparse-types
+ (list hashtable?))
+
+(define type-list
+ (list boolean? bytevector? char? eof-object? hashtable? null? number? pair?
+ port? procedure? string? symbol? vector?))
+
+(define-syntax define-record-type
+ (syntax-rules ()
+ ((_ <name> <constructor> <pred> <field> ...)
+ (begin
+ (%define-record-type <name> <constructor> <pred> <field> ...)
+ (push! type-list <pred>)
+ (register-record-getter <pred> <field> ...)
+ (register-record-setter <pred> <field> ...)))))
+
+(define-syntax register-record-getter
+ (syntax-rules ()
+ ((_ <pred> (<field> <getter> . <rest>) ...)
+ (let ((getters (list (cons '<field> <getter>) ...)))
+ (define (getter record field)
+ (let ((entry (assv field getters)))
+ (if entry
+ ((cdr entry) record)
+ (error "No such field of record." record field))))
+ (alist-add! getter-table <pred> getter)))))
+
+(define-syntax register-record-setter
+ (syntax-rules ()
+ ((_ . <rest>)
+ (%register-record-setter () . <rest>))))
+
+(define-syntax %register-record-setter
+ (syntax-rules ()
+ ((_ <setters> <pred> (<field> <getter>) . <rest>)
+ (%register-record-setter <setters> <pred> . <rest>))
+ ((_ <setters> <pred> (<field> <getter> <setter>) . <rest>)
+ (%register-record-setter ((<field> <setter>) . <setters>) <pred> . <rest>))
+ ((_ ((<field> <setter>) ...) <pred>)
+ (let ((setters (list (cons '<field> <setter>) ...)))
+ (define (setter record field value)
+ (let ((entry (assv field setters)))
+ (if entry
+ ((cdr entry) record value)
+ (error "No such assignable field of record." record field))))
+ (alist-add! setter-table <pred> setter)))))
+
+;;; generic-ref-set.body.scm ends here
diff --git a/generic-ref-set.scm b/generic-ref-set.scm
@@ -1,146 +0,0 @@
-;;; generic-ref-set --- Generic accessor and modifier operators.
-
-;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program 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 General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-(import
- (rename (except (scheme base) set!)
- (define-record-type %define-record-type))
- (scheme case-lambda)
- (r6rs hashtables)
- (srfi 1)
- (rename (srfi 17) (set! %set!)))
-
-;;; Helpers
-
-(define-syntax push!
- (syntax-rules ()
- ((_ <list-var> <x>)
- (set! <list-var> (cons <x> <list-var>)))))
-
-(define-syntax alist-add!
- (syntax-rules ()
- ((_ <alist-var> <key> <value>)
- (push! <alist-var> (cons <key> <value>)))))
-
-;;; Main
-
-(define ref
- (case-lambda
- ((object field)
- (let ((getter (lookup-getter object))
- (sparse? (sparse-type? object)))
- (if sparse?
- (let* ((not-found (cons #f #f))
- (result (getter object field not-found)))
- (if (eqv? result not-found)
- (error "Object has no entry for field." object field)
- result))
- (getter object field))))
- ((object field default)
- (let ((getter (lookup-getter object)))
- (getter object field default)))))
-
-(define-syntax set!
- (syntax-rules ()
- ((set! <place> <expression>)
- (%set! <place> <expression>))
- ((set! <object> <field> <value>)
- (let* ((object <object>)
- (setter (lookup-setter object)))
- (setter object <field> <value>)))))
-
-(set! (setter ref) (lambda (object field value) (set! object field value)))
-
-(define (lookup-getter object)
- (let ((entry (assv (type-of object) getter-table)))
- (if entry
- (cdr entry)
- (error "No generic getter for object's type." object))))
-
-(define (lookup-setter object)
- (let ((entry (assv (type-of object) setter-table)))
- (if entry
- (cdr entry)
- (error "No generic setter for object's type." object))))
-
-(define (sparse-type? object)
- (memv (type-of object) sparse-types))
-
-(define (type-of object)
- (find (lambda (pred) (pred object)) type-list))
-
-(define getter-table
- (list (cons bytevector? bytevector-u8-ref)
- (cons hashtable? hashtable-ref)
- (cons pair? list-ref)
- (cons string? string-ref)
- (cons vector? vector-ref)))
-
-(define setter-table
- (list (cons bytevector? bytevector-u8-set!)
- (cons hashtable? hashtable-set!)
- (cons pair? list-set!)
- (cons string? string-set!)
- (cons vector? vector-set!)))
-
-(define sparse-types
- (list hashtable?))
-
-(define type-list
- (list boolean? bytevector? char? eof-object? hashtable? null? number? pair?
- port? procedure? string? symbol? vector?))
-
-(define-syntax define-record-type
- (syntax-rules ()
- ((_ <name> <constructor> <pred> <field> ...)
- (begin
- (%define-record-type <name> <constructor> <pred> <field> ...)
- (push! type-list <pred>)
- (register-record-getter <pred> <field> ...)
- (register-record-setter <pred> <field> ...)))))
-
-(define-syntax register-record-getter
- (syntax-rules ()
- ((_ <pred> (<field> <getter> . <rest>) ...)
- (let ((getters (list (cons '<field> <getter>) ...)))
- (define (getter record field)
- (let ((entry (assv field getters)))
- (if entry
- ((cdr entry) record)
- (error "No such field of record." record field))))
- (alist-add! getter-table <pred> getter)))))
-
-(define-syntax register-record-setter
- (syntax-rules ()
- ((_ . <rest>)
- (%register-record-setter () . <rest>))))
-
-(define-syntax %register-record-setter
- (syntax-rules ()
- ((_ <setters> <pred> (<field> <getter>) . <rest>)
- (%register-record-setter <setters> <pred> . <rest>))
- ((_ <setters> <pred> (<field> <getter> <setter>) . <rest>)
- (%register-record-setter ((<field> <setter>) . <setters>) <pred> . <rest>))
- ((_ ((<field> <setter>) ...) <pred>)
- (let ((setters (list (cons '<field> <setter>) ...)))
- (define (setter record field value)
- (let ((entry (assv field setters)))
- (if entry
- ((cdr entry) record value)
- (error "No such assignable field of record." record field))))
- (alist-add! setter-table <pred> setter)))))
-
-;;; generic-ref-set.scm ends here
diff --git a/generic-ref-set.sld b/generic-ref-set.sld
@@ -0,0 +1,11 @@
+(define-library (generic-ref-set)
+ (export
+ ref set! define-record-type)
+ (import
+ (rename (except (scheme base) set!)
+ (define-record-type %define-record-type))
+ (scheme case-lambda)
+ (r6rs hashtables)
+ (srfi 1)
+ (rename (srfi 17) (set! %set!)))
+ (include "generic-ref-set.body.scm"))
