117 lines
3.7 KiB
Scheme
117 lines
3.7 KiB
Scheme
;;; -*-scheme-*-
|
|
|
|
;;; GNU Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; This file is part of GNU Mes.
|
|
;;;
|
|
;;; GNU Mes is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
;;; your option) any later version.
|
|
;;;
|
|
;;; GNU Mes is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; srfi-9-vector.mes - records, based on vector
|
|
|
|
(define-macro (define-record-type type constructor+params predicate . fields)
|
|
(let ((record (make-record-type type (map car fields))))
|
|
`(begin
|
|
(define ,type ,record)
|
|
(define ,(car constructor+params) ,(record-constructor record (cdr constructor+params)))
|
|
(define ,predicate ,(record-predicate record))
|
|
(define-record-accessors ,record ,@fields))))
|
|
|
|
(define (make-record-type type fields)
|
|
(list->vector (list '*record-type* type fields (length fields))))
|
|
|
|
(define (record-type? o)
|
|
(eq? (record-type o) '*record-type*))
|
|
|
|
(define (record-type o)
|
|
(vector-ref o 0))
|
|
|
|
(define (record-predicate type)
|
|
(lambda (o)
|
|
(and (vector? o)
|
|
(eq? (record-type o) type))))
|
|
|
|
(define (record-constructor type params)
|
|
(let ((fields (record-fields type)))
|
|
(lambda (. o)
|
|
(if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
|
|
(let ((rest (make-list (- (length fields) (length params)))))
|
|
(list->vector (cons type (append o rest))))))))
|
|
|
|
(define (record-fields o)
|
|
(vector-ref o 2))
|
|
|
|
(define-macro (define-record-accessors type . fields)
|
|
`(begin
|
|
,@(map (lambda (field)
|
|
`(define-record-accessor ,type ,field))
|
|
fields)))
|
|
|
|
(define-macro (define-record-accessor type field)
|
|
`(begin
|
|
(define ,(cadr field) ,(record-getter type (car field)))
|
|
(if ,(pair? (cddr field))
|
|
(define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
|
|
|
|
(define (record-getter type field)
|
|
(let ((i (record-field-index type field)))
|
|
(lambda (o . field?)
|
|
(if (not (eq? (record-type o) type)) (error "record getter: record expected" type o)
|
|
(if (pair? field?) field
|
|
(vector-ref o i))))))
|
|
|
|
(define (record-setter type field)
|
|
(let ((i (record-field-index type field)))
|
|
(lambda (o v)
|
|
(if (not (eq? (record-type o) type)) (error "record setter: record expected" type o)
|
|
(vector-set! o i v)))))
|
|
|
|
(define (record-field-index type field)
|
|
(1+ (or (lst-index (record-fields type) field)
|
|
(error "no such field" type field))))
|
|
|
|
(define (lst-index lst o)
|
|
(let loop ((lst lst) (i 0))
|
|
(and (pair? lst)
|
|
(if (eq? o (car lst)) i
|
|
(loop (cdr lst) (1+ i))))))
|
|
|
|
;; (define-record-type <employee> (make-employee name age salary) employee? (name employe-name) (age employee-age set-employee-age!) (salary employee-salary))
|
|
|
|
;; (display <employee>)
|
|
;; (newline)
|
|
;; (display make-employee)
|
|
;; (newline)
|
|
;; (display "employee-age ")
|
|
;; (display employee-age)
|
|
;; (newline)
|
|
|
|
;; (display "set-employee-age! ")
|
|
;; (display set-employee-age!)
|
|
;; (newline)
|
|
|
|
;; (define janneke (make-employee "janneke" 49 42))
|
|
;; (display janneke)
|
|
;; (newline)
|
|
|
|
;; (display (employee-age janneke))
|
|
;; (newline)
|
|
|
|
;; (display (set-employee-age! janneke 33))
|
|
;; (newline)
|
|
;; (display (employee-age janneke))
|
|
;; (newline)
|