Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-16 17:27:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

WIP

Browse source
This commit is contained in:
Justin Ethier 2016-02-03 02:53:12 -05:00
parent b1091aabd6
commit c90618a74c
2 changed files with 101 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

47
kons.scm
View file

@ -3,19 +3,44 @@
(scheme write)
(srfi 9))
(define-record-type <pare>
(kons x y)
pare?
(x kar set-kar!)
(y kdr))
;((lambda ()
;
;(define-record-type <pare>
; (kons x y)
; pare?
; (x kar) ;TODO: set-kar!)
; (y kdr))
;
;(write
; (list
; (pare? (kons 1 2)) ; =. #t
; (pare? (cons 1 2)) ; =. #f
; (kar (kons 1 2)) ; =. 1
; (kdr (kons 1 2)) ; =. 2
; (let ((k (kons 1 2)))
; (set-kar! k 3)
; (kar k)))) ;=. 3
;; (kar (kons 1 2)) ; =. 1
;; (kdr (kons 1 2)) ; =. 2
;; (let ((k (kons 1 2)))
;; (set-kar! k 3)
;; (kar k)) ;=. 3
;))
;))
;(define <pare> (register-simple-type <pare> #f (quote (x y))))
;(define pare? vector?) ;(make-type-predicate pare? <pare>))
;(define kons
; ((lambda (%make)
; (lambda (x y)
; ((lambda (res)
; (slot-set! <pare> res (type-slot-offset <pare> (quote y)) y)
; (slot-set! <pare> res (type-slot-offset <pare> (quote x)) x)
; res)
; (%make))))
; (make-constructor "kons" <pare>)))
(write
; (list
; (pare? (kons 1 2))
(pair? (cons 1 2))
);)
;(define (make-lambda)
; (lambda (a b c) (write (+ a b c))))
;(define test (make-lambda))
;(test 1 2 3)

93
srfi/9.sld
View file

@ -3,9 +3,41 @@
;;
;;; This is based on the implementation of SRFI 9 from chibi scheme
(define-library (srfi 9)
(export define-record-type)
(import (scheme base))
(export
define-record-type
register-simple-type
make-type-predicate
make-constructor
slot-set!
type-slot-offset
)
(import (scheme base)
(scheme cyclone util))
(begin
(define record-marker (list 'record-marker))
(define (register-simple-type name parent field-tags)
(let ((new (make-vector 3 #f)))
(vector-set! new 0 record-marker)
(vector-set! new 1 name)
(vector-set! new 2 field-tags)
new))
(define (make-type-predicate pred name)
(lambda (obj)
(and (vector? obj)
(equal? (vector-ref obj 0) record-marker)
(equal? (vector-ref obj 1) name))))
(define (make-constructor make name)
(lambda ()
(let* ((field-tags (vector-ref name 2))
(new (make-vector (length field-tags) #f)))
new)))
(define (type-slot-offset name sym)
(let ((field-tags (vector-ref name 2)))
(list-index2 sym field-tags)))
(define (slot-set! name obj idx val)
(let ((vec obj)) ;; TODO: get actual slots from obj
(vector-set! vec idx val)))
(define-syntax define-record-type
(er-macro-transformer
(lambda (expr rename compare)
@ -29,34 +61,37 @@
(error "same binding for record rtd and constructor" name))
`(,(rename 'begin)
;; type
(,_define ,name (,_register ,name-str ,parent ',(map car fields)))
(,_define ,name (,_register
,name ;,name-str
,parent
',(map car fields)))
;; predicate
(,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string pred) ;(identifier->symbol pred))
,pred ;(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)
; ;; 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 '()))
@ -80,4 +115,6 @@
(else
(lp (cdr ls)
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
sets))))))))))))))))
sets)))))))))
)
))))))