andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

mes: srfi-9: Guile interface compliancy. 

* tests/srfi-9.test: Convert to bootstrap test, do not use
mes-use-module.
* mes/module/srfi/srfi-9-vector.mes: Resurrect.
This commit is contained in:
Jan Nieuwenhuizen 2019-11-10 13:11:56 +01:00 committed by Jan (janneke) Nieuwenhuizen
parent e8c81f283b
commit 18df035abc
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
3 changed files with 34 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
mes/module/srfi/srfi-9-vector.mes
View File

@ -34,15 +34,19 @@
(list->vector (list '*record-type* type fields (length fields)))) (list->vector (list '*record-type* type fields (length fields))))
(define (record-type? o) (define (record-type? o)
(eq? (record-type-type o) '*record-type*)) (eq? (record-type-descriptor o) '*record-type*))
(define (struct-vtable o)
(record-type-descriptor o))
(define (record? o) (define (record? o)
(eq? (record-type-type o) '*record*)) (and (vector? o)
(record-type? (record-type-descriptor o))))
(define (record-type-type o) (define (record-type-descriptor o)
(vector-ref o 0)) (vector-ref o 0))
(define (record-type o) (define (record-type-name o)
(vector-ref o 1)) (vector-ref o 1))
(define (record-type-fields o) (define (record-type-fields o)
@ -52,17 +56,16 @@
(lambda (o) (lambda (o)
(and (vector? o) (and (vector? o)
(or (record-type? o) (or (record-type? o)
(record? o)) (record? o)))))
(eq? (record-type o) type))))
(define (record-constructor type . field-names) (define (record-constructor type . type-fields)
(let* ((fields (record-type-fields type)) (let* ((fields (record-type-fields type))
(field-names (if (null? field-names) fields (type-fields (if (null? type-fields) fields
(car field-names)))) (car type-fields))))
(lambda (. o) (lambda (. o)
(if (not (= (length o) (length field-names))) (error "wrong number of arguments for record-constructor") (if (not (= (length o) (length type-fields))) (error "wrong number of arguments for record-constructor")
(let ((rest (make-list (- (length fields) (length field-names))))) (let ((rest (make-list (- (length fields) (length type-fields)))))
(list->vector (cons* '*record* type (append o rest)))))))) (list->vector (cons* type (append o rest))))))))
(define-macro (define-record-accessors type . fields) (define-macro (define-record-accessors type . fields)
`(begin `(begin
@ -79,14 +82,14 @@
(define (record-accessor type field) (define (record-accessor type field)
(let ((i (record-field-index type field))) (let ((i (record-field-index type field)))
(lambda (o . field?) (lambda (o . field?)
(if (not (eq? (record-type o) type)) (error "record accessor: record expected" type o) (if (not (eq? (record-type-descriptor o) type)) (error "record accessor: record expected" type o)
(if (pair? field?) field (if (pair? field?) field
(vector-ref o i)))))) (vector-ref o i))))))
(define (record-modifier type field) (define (record-modifier type field)
(let ((i (record-field-index type field))) (let ((i (record-field-index type field)))
(lambda (o v) (lambda (o v)
(if (not (eq? (record-type o) type)) (error "record modifier: record expected" type o) (if (not (eq? (record-type-descriptor o) type)) (error "record modifier: record expected" type o)
(vector-set! o i v))))) (vector-set! o i v)))))
(define (record-field-index type field) (define (record-field-index type field)

6
mes/module/srfi/srfi-9/gnu-vector.mes
View File

@ -27,11 +27,11 @@
(define-macro (set-field o getters value) (define-macro (set-field o getters value)
`(let ((getter ,(car getters))) `(let ((getter ,(car getters)))
(let ((type (record-type ,o)) (let ((type (record-type-descriptor ,o))
(set (getter ,o #t))) (set (getter ,o #t)))
(define (field->value field) (define (field->value field)
(if (eq? set field) ,value (if (eq? set field) ,value
((record-getter type field) ,o))) ((record-accessor type field) ,o)))
(let* ((fields (record-fields type)) (let* ((fields (record-type-fields type))
(values (map field->value fields))) (values (map field->value fields)))
(apply (record-constructor type fields) values))))) (apply (record-constructor type fields) values)))))

15
tests/srfi-9.test
View File

@ -1,12 +1,16 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-scheme-*-
# bootstrap srfi-9
if [ "$MES" != guile ]; then
MES_BOOT=boot-03.scm exec ${MES-bin/mes} < $0
fi
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests srfi-9)' -s "$0" "$@" exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests srfi-9)' -s "$0" "$@"
!# !#
;;; -*-scheme-*- ;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software ;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
;;; This file is part of GNU Mes. ;;; This file is part of GNU Mes.
;;; ;;;
@ -31,6 +35,15 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
(cond-expand (cond-expand
(mes (mes
;; bootstrap test
(primitive-load "module/mes/test.scm")
(primitive-load "mes/module/srfi/srfi-9-struct.mes")
(primitive-load "mes/module/srfi/srfi-9/gnu-struct.mes")
(define-macro (mes-use-module . rest) #t)
;; (primitive-load "mes/module/srfi/srfi-9-vector.mes")
;; (primitive-load "mes/module/srfi/srfi-9/gnu-vector.mes")
(mes-use-module (srfi srfi-9)) (mes-use-module (srfi srfi-9))
(mes-use-module (srfi srfi-9 gnu)) (mes-use-module (srfi srfi-9 gnu))
(mes-use-module (mes test))) (mes-use-module (mes test)))