diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm index accc1737..f547b342 100644 --- a/piclib/scheme/base.scm +++ b/piclib/scheme/base.scm @@ -732,77 +732,71 @@ (export parameterize make-parameter) -;;; Record Type - (define-library (picrin record) - (import (scheme base) - (picrin macro) - (picrin record-primitive)) - - (define (caddr x) (car (cddr x))) - (define (cdddr x) (cdr (cddr x))) - (define (cadddr x) (car (cdddr x))) - (define (cddddr x) (cdr (cdddr x))) - - (define (make-record-type name) - (let ((rectype (make-record #t))) - (record-set! rectype #t 'name name) - rectype)) - - (define-syntax define-record-constructor - (ir-macro-transformer - (lambda (form inject compare?) - (let ((rectype (cadr form)) - (name (caddr form)) - (fields (cdddr form))) - `(define (,name ,@fields) - (let ((record (make-record ,rectype))) - ,@(map (lambda (field) - `(record-set! record ,rectype ',field ,field)) - fields) - record)))))) - - (define-syntax define-record-predicate - (ir-macro-transformer - (lambda (form inject compare?) - (let ((rectype (cadr form)) - (name (caddr form))) - `(define (,name obj) - (record-of? obj ,rectype)))))) - - (define-syntax define-record-field - (ir-macro-transformer - (lambda (form inject compare?) - (let ((rectype (cadr form)) - (field-name (caddr form)) - (accessor (cadddr form)) - (modifier? (cddddr form))) - (if (null? modifier?) - `(define (,accessor record) - (record-ref record ,rectype ',field-name)) - `(begin - (define (,accessor record) - (record-ref record ,rectype ',field-name)) - (define (,(car modifier?) record val) - (record-set! record ,rectype ',field-name val)))))))) - - (define-syntax define-record-type - (ir-macro-transformer - (lambda (form inject compare?) - (let ((name (cadr form)) - (constructor (caddr form)) - (pred (cadddr form)) - (fields (cddddr form))) - `(begin - (define ,name (make-record-type ',name)) - (define-record-constructor ,name ,@constructor) - (define-record-predicate ,name ,pred) - ,@(map (lambda (field) `(define-record-field ,name ,@field)) - fields)))))) - - (export define-record-type)) + ;; 5.5 Recored-type definitions (import (picrin record)) + (define (caddr x) (car (cddr x))) + (define (cdddr x) (cdr (cddr x))) + (define (cadddr x) (car (cdddr x))) + (define (cddddr x) (cdr (cdddr x))) + + (define (make-record-type name) + (let ((rectype (make-record #t))) + (record-set! rectype #t 'name name) + rectype)) + + (define-syntax define-record-constructor + (ir-macro-transformer + (lambda (form inject compare?) + (let ((rectype (cadr form)) + (name (caddr form)) + (fields (cdddr form))) + `(define (,name ,@fields) + (let ((record (make-record ,rectype))) + ,@(map (lambda (field) + `(record-set! record ,rectype ',field ,field)) + fields) + record)))))) + + (define-syntax define-record-predicate + (ir-macro-transformer + (lambda (form inject compare?) + (let ((rectype (cadr form)) + (name (caddr form))) + `(define (,name obj) + (record-of? obj ,rectype)))))) + + (define-syntax define-record-field + (ir-macro-transformer + (lambda (form inject compare?) + (let ((rectype (cadr form)) + (field-name (caddr form)) + (accessor (cadddr form)) + (modifier? (cddddr form))) + (if (null? modifier?) + `(define (,accessor record) + (record-ref record ,rectype ',field-name)) + `(begin + (define (,accessor record) + (record-ref record ,rectype ',field-name)) + (define (,(car modifier?) record val) + (record-set! record ,rectype ',field-name val)))))))) + + (define-syntax define-record-type + (ir-macro-transformer + (lambda (form inject compare?) + (let ((name (cadr form)) + (constructor (caddr form)) + (pred (cadddr form)) + (fields (cddddr form))) + `(begin + (define ,name (make-record-type ',name)) + (define-record-constructor ,name ,@constructor) + (define-record-predicate ,name ,pred) + ,@(map (lambda (field) `(define-record-field ,name ,@field)) + fields)))))) + (export define-record-type) diff --git a/src/record.c b/src/record.c index af33cbd4..d6d9cde1 100644 --- a/src/record.c +++ b/src/record.c @@ -106,7 +106,7 @@ pic_record_record_set(pic_state *pic) void pic_init_record(pic_state *pic) { - pic_deflibrary (pic, "(picrin record-primitive)") { + pic_deflibrary (pic, "(picrin record)") { pic_defun(pic, "make-record", pic_record_record); pic_defun(pic, "record-of?", pic_record_record_of); pic_defun(pic, "record-ref", pic_record_record_ref);