move (picrin record) to the head of file
This commit is contained in:
Yuichi Nishiwaki
parent
ca8a1f3bf7
commit
54c0ded876
|
|
@ -369,10 +369,153 @@
|
|||
|
||||
(export parameterize))
|
||||
|
||||
;;; Record Type
|
||||
(define-library (picrin record)
|
||||
(import (scheme base)
|
||||
(scheme cxr)
|
||||
(picrin macro)
|
||||
(picrin core-syntax))
|
||||
|
||||
(define record-marker (list 'record-marker))
|
||||
|
||||
(define real-vector? vector?)
|
||||
|
||||
(define (vector? x)
|
||||
(and (real-vector? x)
|
||||
(or (= 0 (vector-length x))
|
||||
(not (eq? (vector-ref x 0)
|
||||
record-marker)))))
|
||||
|
||||
#|
|
||||
;; (scheme eval) is not provided for now
|
||||
(define eval
|
||||
(let ((real-eval eval))
|
||||
(lambda (exp env)
|
||||
((real-eval `(lambda (vector?) ,exp))
|
||||
vector?))))
|
||||
|#
|
||||
|
||||
(define (record? x)
|
||||
(and (real-vector? x)
|
||||
(< 0 (vector-length x))
|
||||
(eq? (vector-ref x 0) record-marker)))
|
||||
|
||||
(define (make-record size)
|
||||
(let ((new (make-vector (+ size 1))))
|
||||
(vector-set! new 0 record-marker)
|
||||
new))
|
||||
|
||||
(define (record-ref record index)
|
||||
(vector-ref record (+ index 1)))
|
||||
|
||||
(define (record-set! record index value)
|
||||
(vector-set! record (+ index 1) value))
|
||||
|
||||
(define record-type% (make-record 3))
|
||||
(record-set! record-type% 0 record-type%)
|
||||
(record-set! record-type% 1 'record-type%)
|
||||
(record-set! record-type% 2 '(name field-tags))
|
||||
|
||||
(define (make-record-type name field-tags)
|
||||
(let ((new (make-record 3)))
|
||||
(record-set! new 0 record-type%)
|
||||
(record-set! new 1 name)
|
||||
(record-set! new 2 field-tags)
|
||||
new))
|
||||
|
||||
(define (record-type record)
|
||||
(record-ref record 0))
|
||||
|
||||
(define (record-type-name record-type)
|
||||
(record-ref record-type 1))
|
||||
|
||||
(define (record-type-field-tags record-type)
|
||||
(record-ref record-type 2))
|
||||
|
||||
(define (field-index type tag)
|
||||
(let rec ((i 1) (tags (record-type-field-tags type)))
|
||||
(cond ((null? tags)
|
||||
(error "record type has no such field" type tag))
|
||||
((eq? tag (car tags)) i)
|
||||
(else (rec (+ i 1) (cdr tags))))))
|
||||
|
||||
(define (record-constructor type tags)
|
||||
(let ((size (length (record-type-field-tags type)))
|
||||
(arg-count (length tags))
|
||||
(indexes (map (lambda (tag) (field-index type tag)) tags)))
|
||||
(lambda args
|
||||
(if (= (length args) arg-count)
|
||||
(let ((new (make-record (+ size 1))))
|
||||
(record-set! new 0 type)
|
||||
(for-each (lambda (arg i) (record-set! new i arg)) args indexes)
|
||||
new)
|
||||
(error "wrong number of arguments to constructor" type args)))))
|
||||
|
||||
(define (record-predicate type)
|
||||
(lambda (thing)
|
||||
(and (record? thing)
|
||||
(eq? (record-type thing)
|
||||
type))))
|
||||
|
||||
(define (record-accessor type tag)
|
||||
(let ((index (field-index type tag)))
|
||||
(lambda (thing)
|
||||
(if (and (record? thing)
|
||||
(eq? (record-type thing)
|
||||
type))
|
||||
(record-ref thing index)
|
||||
(error "accessor applied to bad value" type tag thing)))))
|
||||
|
||||
(define (record-modifier type tag)
|
||||
(let ((index (field-index type tag)))
|
||||
(lambda (thing value)
|
||||
(if (and (record? thing)
|
||||
(eq? (record-type thing)
|
||||
type))
|
||||
(record-set! thing index value)
|
||||
(error "modifier applied to bad value" type tag thing)))))
|
||||
|
||||
(define-syntax define-record-field
|
||||
(ir-macro-transformer
|
||||
(lambda (form inject compare?)
|
||||
(let ((type (cadr form))
|
||||
(field-tag (caddr form))
|
||||
(acc-mod (cdddr form)))
|
||||
(if (= 1 (length acc-mod))
|
||||
`(define ,(car acc-mod)
|
||||
(record-accessor ,type ',field-tag))
|
||||
`(begin
|
||||
(define ,(car acc-mod)
|
||||
(record-accessor ,type ',field-tag))
|
||||
(define ,(cadr acc-mod)
|
||||
(record-modifier ,type ',field-tag))))))))
|
||||
|
||||
(define-syntax define-record-type
|
||||
(ir-macro-transformer
|
||||
(lambda (form inject compare?)
|
||||
(let ((type (cadr form))
|
||||
(constructor (caddr form))
|
||||
(predicate (cadddr form))
|
||||
(field-tag (cddddr form)))
|
||||
`(begin
|
||||
(define ,type
|
||||
(make-record-type ',type ',(cdr constructor)))
|
||||
(define ,(car constructor)
|
||||
(record-constructor ,type ',(cdr constructor)))
|
||||
(define ,predicate
|
||||
(record-predicate ,type))
|
||||
,@(map
|
||||
(lambda (x)
|
||||
`(define-record-field ,type ,(car x) ,(cadr x) ,@(cddr x)))
|
||||
field-tag))))))
|
||||
|
||||
(export define-record-type vector?))
|
||||
|
||||
(import (picrin macro)
|
||||
(picrin core-syntax)
|
||||
(picrin multiple-value)
|
||||
(picrin parameter))
|
||||
(picrin parameter)
|
||||
(picrin record))
|
||||
|
||||
(export let let* letrec letrec*
|
||||
quasiquote unquote unquote-splicing
|
||||
|
|
@ -388,6 +531,9 @@
|
|||
(export make-parameter
|
||||
parameterize)
|
||||
|
||||
(export vector? ; override definition
|
||||
define-record-type)
|
||||
|
||||
(define (every pred list)
|
||||
(if (null? list)
|
||||
#t
|
||||
|
|
@ -746,149 +892,3 @@
|
|||
(write obj port)))))
|
||||
|
||||
(export display))
|
||||
|
||||
;;; Record Type
|
||||
(define-library (picrin record)
|
||||
(import (scheme base)
|
||||
(scheme cxr)
|
||||
(picrin macro))
|
||||
|
||||
(define record-marker (list 'record-marker))
|
||||
|
||||
(define real-vector? vector?)
|
||||
|
||||
(define (vector? x)
|
||||
(and (real-vector? x)
|
||||
(or (= 0 (vector-length x))
|
||||
(not (eq? (vector-ref x 0)
|
||||
record-marker)))))
|
||||
|
||||
#|
|
||||
;; (scheme eval) is not provided for now
|
||||
(define eval
|
||||
(let ((real-eval eval))
|
||||
(lambda (exp env)
|
||||
((real-eval `(lambda (vector?) ,exp))
|
||||
vector?))))
|
||||
|#
|
||||
|
||||
(define (record? x)
|
||||
(and (real-vector? x)
|
||||
(< 0 (vector-length x))
|
||||
(eq? (vector-ref x 0) record-marker)))
|
||||
|
||||
(define (make-record size)
|
||||
(let ((new (make-vector (+ size 1))))
|
||||
(vector-set! new 0 record-marker)
|
||||
new))
|
||||
|
||||
(define (record-ref record index)
|
||||
(vector-ref record (+ index 1)))
|
||||
|
||||
(define (record-set! record index value)
|
||||
(vector-set! record (+ index 1) value))
|
||||
|
||||
(define record-type% (make-record 3))
|
||||
(record-set! record-type% 0 record-type%)
|
||||
(record-set! record-type% 1 'record-type%)
|
||||
(record-set! record-type% 2 '(name field-tags))
|
||||
|
||||
(define (make-record-type name field-tags)
|
||||
(let ((new (make-record 3)))
|
||||
(record-set! new 0 record-type%)
|
||||
(record-set! new 1 name)
|
||||
(record-set! new 2 field-tags)
|
||||
new))
|
||||
|
||||
(define (record-type record)
|
||||
(record-ref record 0))
|
||||
|
||||
(define (record-type-name record-type)
|
||||
(record-ref record-type 1))
|
||||
|
||||
(define (record-type-field-tags record-type)
|
||||
(record-ref record-type 2))
|
||||
|
||||
(define (field-index type tag)
|
||||
(let rec ((i 1) (tags (record-type-field-tags type)))
|
||||
(cond ((null? tags)
|
||||
(error "record type has no such field" type tag))
|
||||
((eq? tag (car tags)) i)
|
||||
(else (rec (+ i 1) (cdr tags))))))
|
||||
|
||||
(define (record-constructor type tags)
|
||||
(let ((size (length (record-type-field-tags type)))
|
||||
(arg-count (length tags))
|
||||
(indexes (map (lambda (tag) (field-index type tag)) tags)))
|
||||
(lambda args
|
||||
(if (= (length args) arg-count)
|
||||
(let ((new (make-record (+ size 1))))
|
||||
(record-set! new 0 type)
|
||||
(for-each (lambda (arg i) (record-set! new i arg)) args indexes)
|
||||
new)
|
||||
(error "wrong number of arguments to constructor" type args)))))
|
||||
|
||||
(define (record-predicate type)
|
||||
(lambda (thing)
|
||||
(and (record? thing)
|
||||
(eq? (record-type thing)
|
||||
type))))
|
||||
|
||||
(define (record-accessor type tag)
|
||||
(let ((index (field-index type tag)))
|
||||
(lambda (thing)
|
||||
(if (and (record? thing)
|
||||
(eq? (record-type thing)
|
||||
type))
|
||||
(record-ref thing index)
|
||||
(error "accessor applied to bad value" type tag thing)))))
|
||||
|
||||
(define (record-modifier type tag)
|
||||
(let ((index (field-index type tag)))
|
||||
(lambda (thing value)
|
||||
(if (and (record? thing)
|
||||
(eq? (record-type thing)
|
||||
type))
|
||||
(record-set! thing index value)
|
||||
(error "modifier applied to bad value" type tag thing)))))
|
||||
|
||||
(define-syntax define-record-field
|
||||
(ir-macro-transformer
|
||||
(lambda (form inject compare?)
|
||||
(let ((type (cadr form))
|
||||
(field-tag (caddr form))
|
||||
(acc-mod (cdddr form)))
|
||||
(if (= 1 (length acc-mod))
|
||||
`(define ,(car acc-mod)
|
||||
(record-accessor ,type ',field-tag))
|
||||
`(begin
|
||||
(define ,(car acc-mod)
|
||||
(record-accessor ,type ',field-tag))
|
||||
(define ,(cadr acc-mod)
|
||||
(record-modifier ,type ',field-tag))))))))
|
||||
|
||||
(define-syntax define-record-type
|
||||
(ir-macro-transformer
|
||||
(lambda (form inject compare?)
|
||||
(let ((type (cadr form))
|
||||
(constructor (caddr form))
|
||||
(predicate (cadddr form))
|
||||
(field-tag (cddddr form)))
|
||||
`(begin
|
||||
(define ,type
|
||||
(make-record-type ',type ',(cdr constructor)))
|
||||
(define ,(car constructor)
|
||||
(record-constructor ,type ',(cdr constructor)))
|
||||
(define ,predicate
|
||||
(record-predicate ,type))
|
||||
,@(map
|
||||
(lambda (x)
|
||||
`(define-record-field ,type ,(car x) ,(cadr x) ,@(cddr x)))
|
||||
field-tag))))))
|
||||
|
||||
(export define-record-type vector?))
|
||||
|
||||
(import (picrin record))
|
||||
|
||||
(export vector? ; override definition
|
||||
define-record-type)
|
||||
|
|
|
|||
Loading…
Reference in New Issue