From 685d21a1e2559a1d1a208e7d0d051db2e7425387 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 17:15:50 +0900 Subject: [PATCH] move define-record-type --- piclib/picrin/record.scm | 92 +++++++++++++++++++++++++++++++++++++++- piclib/scheme/base.scm | 85 +------------------------------------ 2 files changed, 92 insertions(+), 85 deletions(-) diff --git a/piclib/picrin/record.scm b/piclib/picrin/record.scm index b2b72489..00bb3d62 100644 --- a/piclib/picrin/record.scm +++ b/piclib/picrin/record.scm @@ -2,6 +2,8 @@ (import (picrin base) (scheme base)) + ;; define-record-writer + (define (set-record-writer! record-type writer) (record-set! record-type 'writer writer)) @@ -15,4 +17,92 @@ (set-record-writer! type writer)))) - (export define-record-writer)) + ;; define-record-type + + (define ((default-record-writer ctor) obj) + (let ((port (open-output-string))) + (display "#.(" port) + (display (car ctor) port) + (for-each + (lambda (field) + (display " " port) + (write (record-ref obj field) port)) + (cdr ctor)) + (display ")" port) + (get-output-string port))) + + (define ((boot-make-record-type ) name ctor) + (let ((rectype (make-record ))) + (record-set! rectype 'name name) + (record-set! rectype 'writer (default-record-writer ctor)) + rectype)) + + (define + (let (( + ((boot-make-record-type #t) 'record-type '(record-type name writer)))) + (record-set! '@@type ) + )) + + (define make-record-type (boot-make-record-type )) + + (define-syntax define-record-constructor + (ir-macro-transformer + (lambda (form inject compare?) + (let ((rectype (car (cdr form))) + (name (car (cdr (cdr form)))) + (fields (cdr (cdr (cdr form))))) + `(define (,name ,@fields) + (let ((record (make-record ,rectype))) + ,@(map (lambda (field) + `(record-set! record ',field ,field)) + fields) + record)))))) + + (define-syntax define-record-predicate + (ir-macro-transformer + (lambda (form inject compare?) + (let ((rectype (car (cdr form))) + (name (car (cdr (cdr form))))) + `(define (,name obj) + (and (record? obj) + (eq? (record-type obj) + ,rectype))))))) + + (define-syntax define-record-field + (ir-macro-transformer + (lambda (form inject compare?) + (let ((pred (car (cdr form))) + (field-name (car (cdr (cdr form)))) + (accessor (car (cdr (cdr (cdr form))))) + (modifier? (cdr (cdr (cdr (cdr form)))))) + (if (null? modifier?) + `(define (,accessor record) + (if (,pred record) + (record-ref record ',field-name) + (error "wrong record type"))) + `(begin + (define (,accessor record) + (if (,pred record) + (record-ref record ',field-name) + (error "wrong record type"))) + (define (,(car modifier?) record val) + (if (,pred record) + (record-set! record ',field-name val) + (error "wrong record type"))))))))) + + (define-syntax define-record-type + (ir-macro-transformer + (lambda (form inject compare?) + (let ((name (car (cdr form))) + (ctor (car (cdr (cdr form)))) + (pred (car (cdr (cdr (cdr form))))) + (fields (cdr (cdr (cdr (cdr form)))))) + `(begin + (define ,name (make-record-type ',name ',ctor)) + (define-record-constructor ,name ,@ctor) + (define-record-predicate ,name ,pred) + ,@(map (lambda (field) `(define-record-field ,pred ,@field)) + fields)))))) + + (export define-record-type + define-record-writer)) diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm index b166f24e..6af85954 100644 --- a/piclib/scheme/base.scm +++ b/piclib/scheme/base.scm @@ -765,90 +765,7 @@ ;; 5.5 Recored-type definitions - (define ((default-record-writer ctor) obj) - (let ((port (open-output-string))) - (display "#.(" port) - (display (car ctor) port) - (for-each - (lambda (field) - (display " " port) - (write (record-ref obj field) port)) - (cdr ctor)) - (display ")" port) - (get-output-string port))) - - (define ((boot-make-record-type ) name ctor) - (let ((rectype (make-record ))) - (record-set! rectype 'name name) - (record-set! rectype 'writer (default-record-writer ctor)) - rectype)) - - (define - (let (( - ((boot-make-record-type #t) 'record-type '(record-type name writer)))) - (record-set! '@@type ) - )) - - (define make-record-type (boot-make-record-type )) - - (define-syntax define-record-constructor - (ir-macro-transformer - (lambda (form inject compare?) - (let ((rectype (car (cdr form))) - (name (car (cdr (cdr form)))) - (fields (cdr (cdr (cdr form))))) - `(define (,name ,@fields) - (let ((record (make-record ,rectype))) - ,@(map (lambda (field) - `(record-set! record ',field ,field)) - fields) - record)))))) - - (define-syntax define-record-predicate - (ir-macro-transformer - (lambda (form inject compare?) - (let ((rectype (car (cdr form))) - (name (car (cdr (cdr form))))) - `(define (,name obj) - (and (record? obj) - (eq? (record-type obj) - ,rectype))))))) - - (define-syntax define-record-field - (ir-macro-transformer - (lambda (form inject compare?) - (let ((pred (car (cdr form))) - (field-name (car (cdr (cdr form)))) - (accessor (car (cdr (cdr (cdr form))))) - (modifier? (cdr (cdr (cdr (cdr form)))))) - (if (null? modifier?) - `(define (,accessor record) - (if (,pred record) - (record-ref record ',field-name) - (error "wrong record type"))) - `(begin - (define (,accessor record) - (if (,pred record) - (record-ref record ',field-name) - (error "wrong record type"))) - (define (,(car modifier?) record val) - (if (,pred record) - (record-set! record ',field-name val) - (error "wrong record type"))))))))) - - (define-syntax define-record-type - (ir-macro-transformer - (lambda (form inject compare?) - (let ((name (car (cdr form))) - (ctor (car (cdr (cdr form)))) - (pred (car (cdr (cdr (cdr form))))) - (fields (cdr (cdr (cdr (cdr form)))))) - `(begin - (define ,name (make-record-type ',name ',ctor)) - (define-record-constructor ,name ,@ctor) - (define-record-predicate ,name ,pred) - ,@(map (lambda (field) `(define-record-field ,pred ,@field)) - fields)))))) + (import (picrin record)) (export define-record-type)