mes: srfi-9: Add implementation based on struct.
authorJan Nieuwenhuizen <janneke@gnu.org>
Mon, 15 Oct 2018 14:57:00 +0000 (16:57 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Mon, 15 Oct 2018 14:57:00 +0000 (16:57 +0200)
* 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.

mes/module/srfi/srfi-9-struct.mes [new file with mode: 0644]
mes/module/srfi/srfi-9-vector.mes [new file with mode: 0644]
mes/module/srfi/srfi-9.mes [changed from file to symlink]
mes/module/srfi/srfi-9/gnu-struct.mes [new file with mode: 0644]
mes/module/srfi/srfi-9/gnu-vector.mes [new file with mode: 0644]
mes/module/srfi/srfi-9/gnu.mes [changed from file to symlink]
src/hash.c
src/module.c

diff --git a/mes/module/srfi/srfi-9-struct.mes b/mes/module/srfi/srfi-9-struct.mes
new file mode 100644 (file)
index 0000000..0f50920
--- /dev/null
@@ -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)
diff --git a/mes/module/srfi/srfi-9-vector.mes b/mes/module/srfi/srfi-9-vector.mes
new file mode 100644 (file)
index 0000000..f9b436e
--- /dev/null
@@ -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)
deleted file mode 100644 (file)
index 84a5de494185ec19306b3dcfd8da84fced0a3c41..0000000000000000000000000000000000000000
+++ /dev/null
@@ -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)
new file mode 120000 (symlink)
index 0000000000000000000000000000000000000000..863cd6f08550639a3724306ec8a5a23613866341
--- /dev/null
@@ -0,0 +1 @@
+srfi-9-vector.mes
\ No newline at end of file
diff --git a/mes/module/srfi/srfi-9/gnu-struct.mes b/mes/module/srfi/srfi-9/gnu-struct.mes
new file mode 100644 (file)
index 0000000..aacfc4d
--- /dev/null
@@ -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)))))
diff --git a/mes/module/srfi/srfi-9/gnu-vector.mes b/mes/module/srfi/srfi-9/gnu-vector.mes
new file mode 100644 (file)
index 0000000..6f7e084
--- /dev/null
@@ -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)))))
deleted file mode 100644 (file)
index 6f7e084a78b1b172a7caa23ab3cad3b7f6cda877..0000000000000000000000000000000000000000
+++ /dev/null
@@ -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)))))
new file mode 120000 (symlink)
index 0000000000000000000000000000000000000000..d5857c7817683f4d3abd851bcbab5dcfb4a6da64
--- /dev/null
@@ -0,0 +1 @@
+gnu-vector.mes
\ No newline at end of file
index ea91a81d23190693b4f9111fa6043179cb5c6d4d..c334103b95edb8119e6c5b4271405f345492e764 100644 (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
index 92b0d8ca6b7aa4f3f7454009412105eb1700c32d..001efd20c75b28dd7c731b33ef8f7ae06137358d 100644 (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