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) (scheme write)
(srfi 9)) (srfi 9))
(define-record-type <pare> ;((lambda ()
(kons x y) ;
pare? ;(define-record-type <pare>
(x kar set-kar!) ; (kons x y)
(y kdr)) ; pare?
; (x kar) ;TODO: set-kar!)
; (y kdr))
;
;(write ;(write
; (list ; (list
; (pare? (kons 1 2)) ; =. #t ; (pare? (kons 1 2)) ; =. #t
; (pare? (cons 1 2)) ; =. #f ; (pare? (cons 1 2)) ; =. #f
; (kar (kons 1 2)) ; =. 1 ;; (kar (kons 1 2)) ; =. 1
; (kdr (kons 1 2)) ; =. 2 ;; (kdr (kons 1 2)) ; =. 2
; (let ((k (kons 1 2))) ;; (let ((k (kons 1 2)))
; (set-kar! k 3) ;; (set-kar! k 3)
; (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 ;;; This is based on the implementation of SRFI 9 from chibi scheme
(define-library (srfi 9) (define-library (srfi 9)
(export define-record-type) (export
(import (scheme base)) define-record-type
register-simple-type
make-type-predicate
make-constructor
slot-set!
type-slot-offset
)
(import (scheme base)
(scheme cyclone util))
(begin (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 (define-syntax define-record-type
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
@ -29,34 +61,37 @@
(error "same binding for record rtd and constructor" name)) (error "same binding for record rtd and constructor" name))
`(,(rename 'begin) `(,(rename 'begin)
;; type ;; type
(,_define ,name (,_register ,name-str ,parent ',(map car fields))) (,_define ,name (,_register
,name ;,name-str
,parent
',(map car fields)))
;; predicate ;; predicate
(,_define ,pred (,(rename 'make-type-predicate) (,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string pred) ;(identifier->symbol pred)) ,pred ;(symbol->string pred) ;(identifier->symbol pred))
,name)) ,name))
;; fields ; ;; fields
,@(map (lambda (f) ; ,@(map (lambda (f)
(and (pair? f) (pair? (cdr f)) ; (and (pair? f) (pair? (cdr f))
`(,_define ,(cadr f) ; `(,_define ,(cadr f)
(,(rename 'make-getter) ; (,(rename 'make-getter)
,(symbol->string ; ,(symbol->string
(cadr f) ; (cadr f)
;(identifier->symbol (cadr f)) ; ;(identifier->symbol (cadr f))
) ; )
,name ; ,name
(,_type_slot_offset ,name ',(car f)))))) ; (,_type_slot_offset ,name ',(car f))))))
fields) ; fields)
,@(map (lambda (f) ; ,@(map (lambda (f)
(and (pair? f) (pair? (cdr f)) (pair? (cddr f)) ; (and (pair? f) (pair? (cdr f)) (pair? (cddr f))
`(,_define ,(car (cddr f)) ; `(,_define ,(car (cddr f))
(,(rename 'make-setter) ; (,(rename 'make-setter)
,(symbol->string ; ,(symbol->string
(car (cddr f)) ; (car (cddr f))
;(identifier->symbol (car (cddr f))) ; ;(identifier->symbol (car (cddr f)))
) ; )
,name ; ,name
(,_type_slot_offset ,name ',(car f)))))) ; (,_type_slot_offset ,name ',(car f))))))
fields) ; fields)
;; constructor ;; constructor
(,_define ,make (,_define ,make
,(let lp ((ls make-fields) (sets '())) ,(let lp ((ls make-fields) (sets '()))
@ -80,4 +115,6 @@
(else (else
(lp (cdr ls) (lp (cdr ls)
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
sets)))))))))))))))) sets)))))))))
)
))))))