mes: srfi-9: Add implementation based on struct.
* mes/module/srfi/srfi-9-struct.mes: New file. * mes/module/srfi/srfi-9-vector.mes: Rename from srfi-9.mes * mes/module/srfi/srfi-9.mes: Symlink to srfi-9-vector.mes. * mes/module/srfi/srfi-9/gnu-struct.mes: Add srfi-9-struct implementation. * mes/module/srfi/srfi-9/gnu-vector.mes: Rename from gnu.mes. * mes/module/srfi/srfi-9/gnu.mes: Symlink to gnu-vector.mes.
This commit is contained in:
Jan Nieuwenhuizen
parent
8c0a517edf
commit
4ff9b36f26
145
mes/module/srfi/srfi-9-struct.mes
Normal file
145
mes/module/srfi/srfi-9-struct.mes
Normal file
|
|
@ -0,0 +1,145 @@
|
||||||
|
;;; -*-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)
|
||||||
116
mes/module/srfi/srfi-9-vector.mes
Normal file
116
mes/module/srfi/srfi-9-vector.mes
Normal file
|
|
@ -0,0 +1,116 @@
|
||||||
|
;;; -*-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)
|
||||||
|
|
@ -1,138 +0,0 @@
|
||||||
;;; -*-scheme-*-
|
|
||||||
|
|
||||||
;;; GNU Mes --- Maxwell Equations of Software
|
|
||||||
;;; Copyright © 2017 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.
|
|
||||||
|
|
||||||
(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 . 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-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)
|
|
||||||
1
mes/module/srfi/srfi-9.mes
Symbolic link
1
mes/module/srfi/srfi-9.mes
Symbolic link
|
|
@ -0,0 +1 @@
|
||||||
|
srfi-9-vector.mes
|
||||||
38
mes/module/srfi/srfi-9/gnu-struct.mes
Normal file
38
mes/module/srfi/srfi-9/gnu-struct.mes
Normal file
|
|
@ -0,0 +1,38 @@
|
||||||
|
;;; -*-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 - GNU immutable records.
|
||||||
|
|
||||||
|
(define-macro (define-immutable-record-type type constructor+params predicate . fields)
|
||||||
|
`(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
|
||||||
|
|
||||||
|
(define-macro (set-field o getters value)
|
||||||
|
`(let ((getter ,(car getters)))
|
||||||
|
(let* ((type (struct-vtable ,o))
|
||||||
|
(name (record-type ,o))
|
||||||
|
(set (getter ,o #t)))
|
||||||
|
(define (field->value field)
|
||||||
|
(if (eq? set field) ,value
|
||||||
|
((record-getter type field) ,o)))
|
||||||
|
(let* ((fields (record-fields type))
|
||||||
|
(values (map field->value fields)))
|
||||||
|
(apply (record-constructor type name fields) values)))))
|
||||||
37
mes/module/srfi/srfi-9/gnu-vector.mes
Normal file
37
mes/module/srfi/srfi-9/gnu-vector.mes
Normal file
|
|
@ -0,0 +1,37 @@
|
||||||
|
;;; -*-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 - GNU immutable records.
|
||||||
|
|
||||||
|
(define-macro (define-immutable-record-type type constructor+params predicate . fields)
|
||||||
|
`(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
|
||||||
|
|
||||||
|
(define-macro (set-field o getters value)
|
||||||
|
`(let ((getter ,(car getters)))
|
||||||
|
(let ((type (record-type ,o))
|
||||||
|
(set (getter ,o #t)))
|
||||||
|
(define (field->value field)
|
||||||
|
(if (eq? set field) ,value
|
||||||
|
((record-getter type field) ,o)))
|
||||||
|
(let* ((fields (record-fields type))
|
||||||
|
(values (map field->value fields)))
|
||||||
|
(apply (record-constructor type fields) values)))))
|
||||||
|
|
@ -1,37 +0,0 @@
|
||||||
;;; -*-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 - GNU immutable records.
|
|
||||||
|
|
||||||
(define-macro (define-immutable-record-type type constructor+params predicate . fields)
|
|
||||||
`(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
|
|
||||||
|
|
||||||
(define-macro (set-field o getters value)
|
|
||||||
`(let ((getter ,(car getters)))
|
|
||||||
(let ((type (record-type ,o))
|
|
||||||
(set (getter ,o #t)))
|
|
||||||
(define (field->value field)
|
|
||||||
(if (eq? set field) ,value
|
|
||||||
((record-getter type field) ,o)))
|
|
||||||
(let* ((fields (record-fields type))
|
|
||||||
(values (map field->value fields)))
|
|
||||||
(apply (record-constructor type fields) values)))))
|
|
||||||
1
mes/module/srfi/srfi-9/gnu.mes
Symbolic link
1
mes/module/srfi/srfi-9/gnu.mes
Symbolic link
|
|
@ -0,0 +1 @@
|
||||||
|
gnu-vector.mes
|
||||||
|
|
@ -109,7 +109,8 @@ make_hashq_type () ///((internal))
|
||||||
fields = cons (cstring_to_symbol ("buckets"), fields);
|
fields = cons (cstring_to_symbol ("buckets"), fields);
|
||||||
fields = cons (cstring_to_symbol ("size"), fields);
|
fields = cons (cstring_to_symbol ("size"), fields);
|
||||||
fields = cons (hashq_type_name, fields);
|
fields = cons (hashq_type_name, fields);
|
||||||
return make_struct (cstring_to_symbol ("record-type"), fields, cell_unspecified);
|
fields = cons (fields, cell_nil);
|
||||||
|
return make_struct (cstring_to_symbol ("<record-type>"), fields, cell_unspecified);
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
|
|
|
||||||
|
|
@ -30,7 +30,8 @@ make_module_type () ///(internal))
|
||||||
fields = cons (cstring_to_symbol ("locals"), fields);
|
fields = cons (cstring_to_symbol ("locals"), fields);
|
||||||
fields = cons (cstring_to_symbol ("name"), fields);
|
fields = cons (cstring_to_symbol ("name"), fields);
|
||||||
fields = cons (module_type_name, fields);
|
fields = cons (module_type_name, fields);
|
||||||
return make_struct (cstring_to_symbol ("record-type"), fields, cell_unspecified);
|
fields = cons (fields, cell_nil);
|
||||||
|
return make_struct (cstring_to_symbol ("<record-type>"), fields, cell_unspecified);
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue