conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

define 'define-record-type' macro in scheme/base.scm

This commit is contained in:
Yuichi Nishiwaki 2015-07-09 01:59:14 +09:00
parent 5f454626f6
commit 3bcc4b15fc
4 changed files with 51 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile
View File

@ -10,7 +10,6 @@ PICRIN_OBJS = \
PICRIN_LIBS = \ PICRIN_LIBS = \
piclib/picrin/base.scm\ piclib/picrin/base.scm\
piclib/picrin/macro.scm\ piclib/picrin/macro.scm\
piclib/picrin/record.scm\
piclib/picrin/control.scm\ piclib/picrin/control.scm\
piclib/picrin/experimental/lambda.scm\ piclib/picrin/experimental/lambda.scm\
piclib/picrin/syntax-rules.scm\ piclib/picrin/syntax-rules.scm\

51
contrib/20.r7rs/scheme/base.scm
View File

@ -1,7 +1,6 @@
(define-library (scheme base) (define-library (scheme base)
(import (picrin base) (import (picrin base)
(picrin macro) (picrin macro)
(picrin record)
(picrin syntax-rules) (picrin syntax-rules)
(picrin string) (picrin string)
(scheme file)) (scheme file))
@ -171,6 +170,56 @@
;; 5.5 Recored-type definitions ;; 5.5 Recored-type definitions
(define ((boot-make-record-type <meta-type>) name)
(let ((rectype (make-record <meta-type>)))
(record-set! rectype 'name name)
rectype))
(define <record-type>
(let ((<record-type> ((boot-make-record-type #t) 'record-type)))
(record-set! <record-type> '@@type <record-type>)
<record-type>))
(define make-record-type (boot-make-record-type <record-type>))
(define-syntax (define-record-constructor type name . fields)
(let ((record #'record))
#`(define (#,name . #,fields)
(let ((#,record (make-record #,type)))
#,@(map (lambda (field) #`(record-set! #,record '#,field #,field)) fields)
#,record))))
(define-syntax (define-record-predicate type name)
#`(define (#,name obj)
(and (record? obj)
(eq? (record-type obj) #,type))))
(define-syntax (define-record-accessor pred field accessor)
#`(define (#,accessor record)
(if (#,pred record)
(record-ref record '#,field)
(error (string-append (symbol->string '#,accessor) ": wrong record type") record))))
(define-syntax (define-record-modifier pred field modifier)
#`(define (#,modifier record val)
(if (#,pred record)
(record-set! record '#,field val)
(error (string-append (symbol->string '#,modifier) ": wrong record type") record))))
(define-syntax (define-record-field pred field accessor . modifier-opt)
(if (null? modifier-opt)
#`(define-record-accessor #,pred #,field #,accessor)
#`(begin
(define-record-accessor #,pred #,field #,accessor)
(define-record-modifier #,pred #,field #,(car modifier-opt)))))
(define-syntax (define-record-type name ctor pred . fields)
#`(begin
(define #,name (make-record-type '#,name))
(define-record-constructor #,name #,@ctor)
(define-record-predicate #,name #,pred)
#,@(map (lambda (field) #`(define-record-field #,pred #,@field)) fields)))
(export define-record-type) (export define-record-type)
;; 6.1. Equivalence predicates ;; 6.1. Equivalence predicates

3
contrib/90.array/array.scm
View File

@ -1,6 +1,5 @@
(define-library (picrin array) (define-library (picrin array)
(import (picrin base) (import (scheme base))
(picrin record))
(define-record-type <array> (define-record-type <array>
(create-array data size head tail) (create-array data size head tail)

59
piclib/picrin/record.scm
View File

@ -1,59 +0,0 @@
(define-library (picrin record)
(import (picrin base)
(picrin macro))
;; record meta type
(define ((boot-make-record-type <meta-type>) name)
(let ((rectype (make-record <meta-type>)))
(record-set! rectype 'name name)
rectype))
(define <record-type>
(let ((<record-type> ((boot-make-record-type #t) 'record-type)))
(record-set! <record-type> '@@type <record-type>)
<record-type>))
(define make-record-type (boot-make-record-type <record-type>))
;; define-record-type
(define-syntax (define-record-constructor type name . fields)
(let ((record #'record))
#`(define (#,name . #,fields)
(let ((#,record (make-record #,type)))
#,@(map (lambda (field) #`(record-set! #,record '#,field #,field)) fields)
#,record))))
(define-syntax (define-record-predicate type name)
#`(define (#,name obj)
(and (record? obj)
(eq? (record-type obj) #,type))))
(define-syntax (define-record-accessor pred field accessor)
#`(define (#,accessor record)
(if (#,pred record)
(record-ref record '#,field)
(error (string-append (symbol->string '#,accessor) ": wrong record type") record))))
(define-syntax (define-record-modifier pred field modifier)
#`(define (#,modifier record val)
(if (#,pred record)
(record-set! record '#,field val)
(error (string-append (symbol->string '#,modifier) ": wrong record type") record))))
(define-syntax (define-record-field pred field accessor . modifier-opt)
(if (null? modifier-opt)
#`(define-record-accessor #,pred #,field #,accessor)
#`(begin
(define-record-accessor #,pred #,field #,accessor)
(define-record-modifier #,pred #,field #,(car modifier-opt)))))
(define-syntax (define-record-type name ctor pred . fields)
#`(begin
(define #,name (make-record-type '#,name))
(define-record-constructor #,name #,@ctor)
(define-record-predicate #,name #,pred)
#,@(map (lambda (field) #`(define-record-field #,pred #,@field)) fields)))
(export define-record-type))