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

move (picrin record) to the head of file

This commit is contained in:
Yuichi Nishiwaki 2014-02-19 02:01:02 +09:00
parent ca8a1f3bf7
commit 54c0ded876
1 changed files with 147 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

294
piclib/built-in.scm
View File

@ -369,10 +369,153 @@
(export parameterize)) (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) (import (picrin macro)
(picrin core-syntax) (picrin core-syntax)
(picrin multiple-value) (picrin multiple-value)
(picrin parameter)) (picrin parameter)
(picrin record))
(export let let* letrec letrec* (export let let* letrec letrec*
quasiquote unquote unquote-splicing quasiquote unquote unquote-splicing
@ -388,6 +531,9 @@
(export make-parameter (export make-parameter
parameterize) parameterize)
(export vector? ; override definition
define-record-type)
(define (every pred list) (define (every pred list)
(if (null? list) (if (null? list)
#t #t
@ -746,149 +892,3 @@
(write obj port))))) (write obj port)))))
(export display)) (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)