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 2018-10-15 16:57:00 +02:00
parent 8c0a517edf
commit 4ff9b36f26
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
8 changed files with 342 additions and 177 deletions

View 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)

View 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)

View file

@ -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
View file

@ -0,0 +1 @@
srfi-9-vector.mes

View 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)))))

View 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)))))

View file

@ -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)))))

View file

@ -0,0 +1 @@
gnu-vector.mes

View file

@ -109,7 +109,8 @@ make_hashq_type () ///((internal))
fields = cons (cstring_to_symbol ("buckets"), fields);
fields = cons (cstring_to_symbol ("size"), 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

View file

@ -30,7 +30,8 @@ make_module_type () ///(internal))
fields = cons (cstring_to_symbol ("locals"), fields);
fields = cons (cstring_to_symbol ("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