From cbb15c98dcb23dc3b6e480b3241e6b2e2f89a253 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 28 Apr 2016 03:45:38 -0400 Subject: [PATCH] Moving record types to (scheme base) --- docs/Scheme-Language-Compliance.md | 2 +- scheme/base.sld | 124 ++++++++++++++++++++++++++++- 2 files changed, 124 insertions(+), 2 deletions(-) diff --git a/docs/Scheme-Language-Compliance.md b/docs/Scheme-Language-Compliance.md index d8ce6f9c..4d799e9d 100644 --- a/docs/Scheme-Language-Compliance.md +++ b/docs/Scheme-Language-Compliance.md @@ -28,7 +28,7 @@ Section | Status | Comments 5.2 Import declarations | Partial | 5.3 Variable definitions | Partial | `define-values` is not implemented yet. 5.4 Syntax definitions | Yes | -5.5 Record-type definitions | Yes | Located in the `(srfi 9)` library. +5.5 Record-type definitions | Yes | 5.6 Libraries | Partial | Support is "good enough" but need to make it more robust 5.7 The REPL | Yes | 6.1 Equivalence predicates | Yes | `eqv?` is not implemented, it is just an alias to `eq?` diff --git a/scheme/base.sld b/scheme/base.sld index 9643b628..4cbd9f0c 100644 --- a/scheme/base.sld +++ b/scheme/base.sld @@ -18,7 +18,8 @@ ;delete ;delete-duplicates ;; TODO: possibly relocating here in the future - ;define-record-type + define-record-type + record? ; register-simple-type ; make-type-predicate ; make-constructor @@ -1358,4 +1359,125 @@ (if test (begin result1 result2 ...) (guard-aux reraise clause1 clause2 ...))))) + +;; Record-type definitions +(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-index2 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)))) + +(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))))))))) + ))))) ))