mes: Add unfold.
[mes.git] / module / srfi / srfi-9.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; srfi-9.mes - records.
24
25 (define (lst-index lst o)
26   (let loop ((lst lst) (i 0))
27     (and (pair? lst)
28          (if (equal? o (car lst)) i
29              (loop (cdr lst) (1+ i))))))
30
31 (define (make-record-type type fields)
32   (list->vector (list '*record-type* type fields (length fields))))
33
34 (define (record-type o)
35   (vector-ref o 0))
36
37 (define (record-type? o)
38   (eq? (record-type o) '*record-type*))
39
40 (define (record-constructor type params)
41   (let ((fields (record-fields type)))
42     (lambda (. o)
43       (if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
44           (let ((rest (make-list (- (length fields) (length params)))))
45             (list->vector (cons type (append o rest))))))))
46
47 (define (record-fields o)
48   (vector-ref o 2))
49
50 (define (record-field-index type field)
51   (1+ (or (lst-index (record-fields type) field)
52           (error "no such field" type field))))
53
54 (define (record-getter type field)
55   (let ((i (record-field-index type field)))
56     (lambda (o . field?)
57       (if (not (eq? (record-type o) type)) (error "record getter: record expected" type o)
58           (if (pair? field?) field
59               (vector-ref o i))))))
60
61 (define (record-setter type field)
62   (let ((i (record-field-index type field)))
63     (lambda (o v)
64       (if (not (eq? (record-type o) type)) (error "record setter: record expected" type o)
65           (vector-set! o i v)))))
66
67 (define (record-predicate type)
68   (lambda (o)
69     (and (vector? o)
70          (eq? (record-type o) type))))
71
72 (define-macro (define-record-accessors type . fields)
73   `(begin
74      ,@(map (lambda (field)
75               `(define-record-accessor ,type ,field))
76             fields)))
77
78 (define-macro (define-record-accessor type field)
79   `(begin
80      (define ,(cadr field) ,(record-getter type (car field)))
81      (if ,(pair? (cddr field))
82          (define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
83
84 (define-macro (define-record-type type constructor+params predicate . fields)
85   (let ((record (make-record-type type (map car fields))))
86    `(begin
87       (define ,type ,record)
88       (define ,(car constructor+params) ,(record-constructor record (cdr constructor+params)))
89       (define ,predicate ,(record-predicate record))
90       (define-record-accessors ,record ,@fields))))
91
92 ;; (define-record-type cpi
93 ;;   (make-cpi-1)
94 ;;   cpi?
95 ;;   (debug cpi-debug set-cpi-debug!)   ; debug #t #f
96 ;;   (defines cpi-defs set-cpi-defs!)   ; #defines
97 ;;   (incdirs cpi-incs set-cpi-incs!)   ; #includes
98 ;;   (inc-tynd cpi-itynd set-cpi-itynd!)        ; a-l of incfile => typenames
99 ;;   (inc-defd cpi-idefd set-cpi-idefd!)        ; a-l of incfile => defines
100 ;;   (ptl cpi-ptl set-cpi-ptl!)         ; parent typename list
101 ;;   (ctl cpi-ctl set-cpi-ctl!)         ; current typename list
102 ;;   (blev cpi-blev set-cpi-blev!)              ; curr brace/block level
103 ;;   )
104
105 ;; (display cpi)
106 ;; (newline)
107 ;; (display make-cpi-1)
108 ;; (newline)
109 ;; (define cpi (make-cpi-1))
110 ;; (set-cpi-debug! cpi #t)
111 ;; (set-cpi-blev! cpi #t)
112
113
114 ;; (define-record-type <employee> (make-employee name age salary) employee? (name employe-name) (age  employee-age set-employee-age!) (salary employee-salary))
115
116 ;; (display <employee>)
117 ;; (newline)
118 ;; (display make-employee)
119 ;; (newline)
120 ;; (display "employee-age ")
121 ;; (display employee-age)
122 ;; (newline)
123
124 ;; (display "set-employee-age! ")
125 ;; (display set-employee-age!)
126 ;; (newline)
127
128 ;; (define janneke (make-employee "janneke" 49 42))
129 ;; (display janneke)
130 ;; (newline)
131
132 ;; (display (employee-age janneke))
133 ;; (newline)
134
135 ;; (display (set-employee-age! janneke 33))
136 ;; (newline)
137 ;; (display (employee-age janneke))
138 ;; (newline)