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

Issue #428 - Removed obsolete (srfi 9)

Browse source
This commit is contained in:
Justin Ethier 2020-12-29 21:30:51 -05:00
parent 1c5e7f0aa2
commit 6a59ab2a5d
2 changed files with 0 additions and 156 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -288,8 +288,6 @@ bootstrap : icyc libs
cp srfi/1.c $(BOOTSTRAP_DIR)/srfi
cp srfi/2.c $(BOOTSTRAP_DIR)/srfi
cp srfi/2.meta $(BOOTSTRAP_DIR)/srfi
cp srfi/9.c $(BOOTSTRAP_DIR)/srfi
cp srfi/9.meta $(BOOTSTRAP_DIR)/srfi
cp srfi/18.c $(BOOTSTRAP_DIR)/srfi
cp srfi/27.c $(BOOTSTRAP_DIR)/srfi
cp srfi/28.c $(BOOTSTRAP_DIR)/srfi

154
srfi/9.sld
View file

@ -1,154 +0,0 @@
;;;; Cyclone Scheme
;;;; https://github.com/justinethier/cyclone
;;;;
;;;; Copyright (c) 2014-2016, Justin Ethier
;;;; All rights reserved.
;;;;
;;;; This is based on the implementation of SRFI 9 from chibi scheme.
;;;;
(define-library (srfi 9)
(export
record?
define-record-type
register-simple-type
make-type-predicate
make-constructor
make-getter
make-setter
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))
(field-values (make-vector (length field-tags) #f))
(new (make-vector 3 #f))
)
(vector-set! new 0 record-marker)
(vector-set! new 1 name)
(vector-set! new 2 field-values)
new)))
(define (type-slot-offset name sym)
(let ((field-tags (vector-ref name 2)))
(_list-index sym field-tags)))
(define (slot-set! name obj idx val)
(let ((vec obj)) ;; TODO: get actual slots from obj
(vector-set! (vector-ref vec 2) idx val)))
(define (make-getter sym name idx)
(lambda (obj)
(vector-ref (vector-ref obj 2) idx)))
(define (make-setter sym name idx)
(lambda (obj val)
(vector-set! (vector-ref obj 2) idx val)))
(define (record? obj)
(and (vector? obj)
(> (vector-length obj) 0)
(equal? record-marker (vector-ref obj 0))))
;; Find index of element in list, or -1 if not found
(define _list-index
(lambda (e lst)
(if (null? lst)
-1
(if (eq? (car lst) e)
0
(if (= (_list-index e (cdr lst)) -1)
-1
(+ 1 (_list-index e (cdr lst))))))))
(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 ;,name-str
,parent
',(map car fields)))
;; predicate
(,_define ,pred (,(rename 'make-type-predicate)
,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)
;; 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)))))))))
)
))))))