0f042b6ea6
* module/srfi/srfi-9.mes (define-record-type): New macro. * AUTHORS: Update. * module/mes/record-0.mes: Remove. * module/mes/record.mes: Remove. * module/srfi/srfi-9-psyntax.mes: Remove. * module/srfi/srfi-9.scm: Remove. * make.scm: Remove them.
138 lines
4.3 KiB
Scheme
138 lines
4.3 KiB
Scheme
;;; -*-scheme-*-
|
|
|
|
;;; Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; This file is part of Mes.
|
|
;;;
|
|
;;; 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.
|
|
;;;
|
|
;;; 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 Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; srfi-9.mes - records.
|
|
|
|
(define (lst-index lst o)
|
|
(let loop ((lst lst) (i 0))
|
|
(and (pair? lst)
|
|
(if (equal? o (car lst)) i
|
|
(loop (cdr lst) (1+ i))))))
|
|
|
|
(define (make-record-type type fields)
|
|
(list->vector (list '*record-type* type fields (length fields))))
|
|
|
|
(define (record-type o)
|
|
(vector-ref o 0))
|
|
|
|
(define (record-type? o)
|
|
(eq? (record-type o) '*record-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 (record-field-index type field)
|
|
(1+ (or (lst-index (record-fields type) field)
|
|
(error "no such field" type field))))
|
|
|
|
(define (record-getter type field)
|
|
(let ((i (record-field-index type field)))
|
|
(lambda (o)
|
|
(if (not (eq? (record-type o) type)) (error "record getter: record expected" type o)
|
|
(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-predicate type)
|
|
(lambda (o)
|
|
(and (vector? o)
|
|
(eq? (record-type o) type))))
|
|
|
|
(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-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-record-type cpi
|
|
;; (make-cpi-1)
|
|
;; cpi?
|
|
;; (debug cpi-debug set-cpi-debug!) ; debug #t #f
|
|
;; (defines cpi-defs set-cpi-defs!) ; #defines
|
|
;; (incdirs cpi-incs set-cpi-incs!) ; #includes
|
|
;; (inc-tynd cpi-itynd set-cpi-itynd!) ; a-l of incfile => typenames
|
|
;; (inc-defd cpi-idefd set-cpi-idefd!) ; a-l of incfile => defines
|
|
;; (ptl cpi-ptl set-cpi-ptl!) ; parent typename list
|
|
;; (ctl cpi-ctl set-cpi-ctl!) ; current typename list
|
|
;; (blev cpi-blev set-cpi-blev!) ; curr brace/block level
|
|
;; )
|
|
|
|
;; (display cpi)
|
|
;; (newline)
|
|
;; (display make-cpi-1)
|
|
;; (newline)
|
|
;; (define cpi (make-cpi-1))
|
|
;; (set-cpi-debug! cpi #t)
|
|
;; (set-cpi-blev! cpi #t)
|
|
|
|
|
|
;; (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)
|