diff --git a/Makefile b/Makefile index fc132d17..f0da8ddb 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/srfi/9.sld b/srfi/9.sld deleted file mode 100644 index b286e32a..00000000 --- a/srfi/9.sld +++ /dev/null @@ -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))))))))) - ) - ))))))