Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-05-23 20:15:05 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Initial file, not working yet

Browse source
This commit is contained in:
Justin Ethier 2016-01-29 23:11:32 -05:00
parent 28c3b8d6b6
commit 43e0cfdd4c
1 changed files with 83 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

83
srfi/9.sld Normal file
View file

@ -0,0 +1,83 @@
;; TODO: this does not work yet, need (begin) to be able to inject
;; define's in its outer scope
;;
;;; This is based on the implementation of SRFI 9 from chibi scheme
(define-library (srfi 9)
(export define-record-type)
;(import (scheme base))
(begin
(define-syntax define-record-type
(er-macro-transformer
(lambda (expr rename compare)
(let* ((name+parent (cadr expr))
(name (if (pair? name+parent) (car name+parent) name+parent))
(parent (and (pair? name+parent) (cadr name+parent)))
(name-str (symbol->string name)) ;(identifier->symbol name)))
(procs (cddr expr))
(make (caar procs))
(make-fields (cdar procs))
(pred (cadr procs))
(fields (cddr procs))
(_define (rename 'define))
(_lambda (rename 'lambda))
(_let (rename 'let))
(_register (rename 'register-simple-type))
(_slot-set! (rename 'slot-set!))
(_type_slot_offset (rename 'type-slot-offset)))
;; catch a common mistake
(if (eq? name make)
(error "same binding for record rtd and constructor" name))
`(,(rename 'begin)
;; type
(,_define ,name (,_register ,name-str ,parent ',(map car fields)))
;; predicate
(,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string pred) ;(identifier->symbol pred))
,name))
;; fields
,@(map (lambda (f)
(and (pair? f) (pair? (cdr f))
`(,_define ,(cadr f)
(,(rename 'make-getter)
,(symbol->string
(cadr f)
;(identifier->symbol (cadr f))
)
,name
(,_type_slot_offset ,name ',(car f))))))
fields)
,@(map (lambda (f)
(and (pair? f) (pair? (cdr f)) (pair? (cddr f))
`(,_define ,(car (cddr f))
(,(rename 'make-setter)
,(symbol->string
(car (cddr f))
;(identifier->symbol (car (cddr f)))
)
,name
(,_type_slot_offset ,name ',(car f))))))
fields)
;; constructor
(,_define ,make
,(let lp ((ls make-fields) (sets '()))
(cond
((null? ls)
`(,_let ((%make (,(rename 'make-constructor)
,(symbol->string make) ;(identifier->symbol make))
,name)))
(,_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 `(,(car (cddr field)) res ,(car ls)) sets)))
(else
(lp (cdr ls)
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
sets))))))))))))))))