Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 22:59:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding srfi-9 based on native types

Browse source
This commit is contained in:
Alex Shinn 2009-11-11 01:27:20 +09:00
parent f53e4df208
commit edd08d6740
2 changed files with 84 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
TODO
View file

@ -27,7 +27,7 @@
**- scheme-complete.el support **- scheme-complete.el support
*= ffi *= ffi
**+ libdl interface **+ libdl interface
**- opcode generation interface **= opcode generation interface
**- stub generator **- stub generator
*= cleanup *= cleanup
*- user documentation *- user documentation
@ -45,5 +45,5 @@
**- plugin infrastructure **- plugin infrastructure
*- type inference with warnings *- type inference with warnings
*- SRFI-0 cond-expand *- SRFI-0 cond-expand
*- SRFI-9 define-record-type *+ SRFI-9 define-record-type
*- code repository with install tools *- code repository with install tools

82
lib/srfi/9.module Normal file
View file

@ -0,0 +1,82 @@
(define-module (srfi 9)
(export define-record-type)
(import (scheme))
(body
(define-syntax define-record-type
(er-macro-transformer
(lambda (expr rename compare)
(let* ((name (cadr expr))
(make (caaddr expr))
(make-fields (cdaddr expr))
(pred (cadddr expr))
(fields (cddddr expr))
(num-fields (length fields))
(index (register-simple-type (symbol->string name) num-fields))
(_define (rename 'define))
(_lambda (rename 'lambda))
(_let (rename 'let)))
(define (index-of field ls)
(let lp ((ls ls) (i 0))
(if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1)))))
`(,(rename 'begin)
(,_define ,make
,(let lp ((ls make-fields) (sets '()) (set-defs '()))
(cond
((null? ls)
`(,_let ((%make (,(rename 'make-constructor)
,(symbol->string make)
,index))
,@set-defs)
(,_lambda ,make-fields
(,_let ((res (%make)))
,@sets
res))))
(else
(let ((field (assq (car ls) fields)))
(cond
((not field)
(error "unknown record field in constructor" (car ls)))
((pair? (cddr field))
(lp (cdr ls)
(cons (list (caddr field) 'res (car ls)) sets)
set-defs))
(else
(let* ((setter-name
(string-append "%" (symbol->string name) "-"
(symbol->string (car ls)) "-set!"))
(setter (rename (string->symbol setter-name)))
(i (index-of (car ls) fields)))
(lp (cdr ls)
(cons (list setter 'res (car ls)) sets)
(cons (list setter
(list (rename 'make-setter)
setter-name
index
(index-of (car ls) fields)))
set-defs))))))))))
(,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string pred)
,index))
,@(let lp ((ls fields) (i 0) (res '()))
(if (null? ls)
res
(let ((res
(cons `(,_define ,(cadar ls)
(,(rename 'make-getter)
,(symbol->string (cadar ls))
,index
,i))
res)))
(lp (cdr ls)
(+ i 1)
(if (pair? (cddar ls))
(cons
`(,_define ,(caddar ls)
(,(rename 'make-setter)
,(symbol->string (caddar ls))
,index
,i))
res)
res))))))))))))