146 lines
4.4 KiB
Scheme
146 lines
4.4 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.mes - records, based on struct.
|
|
|
|
(define-macro (define-record-type name constructor+params predicate . fields)
|
|
(let ((type (make-record-type name (map car fields))))
|
|
`(begin
|
|
(define ,name ,type)
|
|
(define ,(car constructor+params) ,(record-constructor type name (cdr constructor+params)))
|
|
(define ,predicate ,(record-predicate type))
|
|
(define-record-accessors ,type ,@fields))))
|
|
|
|
(define (make-record-type type fields . printer)
|
|
(let ((printer (if (pair? printer) (car printer))))
|
|
(make-struct '<record-type> (cons type (list fields)) printer)))
|
|
|
|
(define (record-type? o)
|
|
(eq? (struct-vtable o) '<record-type>))
|
|
|
|
(define (struct-vtable o)
|
|
(struct-ref o 0))
|
|
|
|
(define (record-type o)
|
|
(struct-ref o 2))
|
|
|
|
(define (record-predicate type)
|
|
(lambda (o)
|
|
(and (record? o)
|
|
(eq? (record-type o) (record-type type)))))
|
|
|
|
(define (record? o)
|
|
(and (struct? o)
|
|
(record-type? (struct-vtable o))))
|
|
|
|
(define (record-constructor type name params)
|
|
(let ((fields (record-fields type))
|
|
(record-type (record-type 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)))))
|
|
(make-struct type (cons name (append o rest)) record-printer))))))
|
|
|
|
(define record-printer *unspecified*) ; TODO
|
|
(define (record-printer o)
|
|
(display "#<")
|
|
(display (record-type o))
|
|
(let* ((vtable (struct-vtable o))
|
|
(fields (record-fields vtable)))
|
|
(for-each (lambda (field)
|
|
(display " ")
|
|
(display field)
|
|
(display ": ")
|
|
(display ((record-getter vtable field) o)))
|
|
fields))
|
|
(display ">"))
|
|
|
|
(define (record-fields o)
|
|
(struct-ref o 3))
|
|
|
|
(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) (record-type type))) (error "record getter: record expected" type o)
|
|
(if (pair? field?) field
|
|
(struct-ref o i))))))
|
|
|
|
(define (record-setter type field)
|
|
(let ((i (record-field-index type field)))
|
|
(lambda (o v)
|
|
(if (not (eq? (record-type o) (record-type type))) (error "record setter: record expected" type o)
|
|
(struct-set! o i v)))))
|
|
|
|
(define (record-field-index type field)
|
|
(+ 3 (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)
|