From 4ff9b36f267a5208e3a90fc79333f8de3dd2a82b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 15 Oct 2018 16:57:00 +0200 Subject: [PATCH] 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. --- mes/module/srfi/srfi-9-struct.mes | 145 ++++++++++++++++++++++++++ mes/module/srfi/srfi-9-vector.mes | 116 +++++++++++++++++++++ mes/module/srfi/srfi-9.mes | 139 +----------------------- mes/module/srfi/srfi-9/gnu-struct.mes | 38 +++++++ mes/module/srfi/srfi-9/gnu-vector.mes | 37 +++++++ mes/module/srfi/srfi-9/gnu.mes | 38 +------ src/hash.c | 3 +- src/module.c | 3 +- 8 files changed, 342 insertions(+), 177 deletions(-) create mode 100644 mes/module/srfi/srfi-9-struct.mes create mode 100644 mes/module/srfi/srfi-9-vector.mes mode change 100644 => 120000 mes/module/srfi/srfi-9.mes create mode 100644 mes/module/srfi/srfi-9/gnu-struct.mes create mode 100644 mes/module/srfi/srfi-9/gnu-vector.mes mode change 100644 => 120000 mes/module/srfi/srfi-9/gnu.mes diff --git a/mes/module/srfi/srfi-9-struct.mes b/mes/module/srfi/srfi-9-struct.mes new file mode 100644 index 00000000..0f509203 --- /dev/null +++ b/mes/module/srfi/srfi-9-struct.mes @@ -0,0 +1,145 @@ +;;; -*-scheme-*- + +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +;;; 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 ' (cons type (list fields)) printer))) + +(define (record-type? o) + (eq? (struct-vtable o) ')) + +(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 +;; (make-employee name age salary) +;; employee? +;; (name employe-name) +;; (age employee-age set-employee-age!) +;; (salary employee-salary)) + +;; (display ) +;; (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 index 00000000..f9b436ef --- /dev/null +++ b/mes/module/srfi/srfi-9-vector.mes @@ -0,0 +1,116 @@ +;;; -*-scheme-*- + +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +;;; 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 (make-employee name age salary) employee? (name employe-name) (age employee-age set-employee-age!) (salary employee-salary)) + +;; (display ) +;; (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.mes b/mes/module/srfi/srfi-9.mes deleted file mode 100644 index 84a5de49..00000000 --- a/mes/module/srfi/srfi-9.mes +++ /dev/null @@ -1,138 +0,0 @@ -;;; -*-scheme-*- - -;;; GNU Mes --- Maxwell Equations of Software -;;; Copyright © 2017 Jan (janneke) Nieuwenhuizen -;;; -;;; 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 . - -;;; 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 (make-employee name age salary) employee? (name employe-name) (age employee-age set-employee-age!) (salary employee-salary)) - -;; (display ) -;; (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.mes b/mes/module/srfi/srfi-9.mes new file mode 120000 index 00000000..863cd6f0 --- /dev/null +++ b/mes/module/srfi/srfi-9.mes @@ -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 index 00000000..aacfc4d1 --- /dev/null +++ b/mes/module/srfi/srfi-9/gnu-struct.mes @@ -0,0 +1,38 @@ +;;; -*-scheme-*- + +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +;;; 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 index 00000000..6f7e084a --- /dev/null +++ b/mes/module/srfi/srfi-9/gnu-vector.mes @@ -0,0 +1,37 @@ +;;; -*-scheme-*- + +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +;;; 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))))) diff --git a/mes/module/srfi/srfi-9/gnu.mes b/mes/module/srfi/srfi-9/gnu.mes deleted file mode 100644 index 6f7e084a..00000000 --- a/mes/module/srfi/srfi-9/gnu.mes +++ /dev/null @@ -1,37 +0,0 @@ -;;; -*-scheme-*- - -;;; GNU Mes --- Maxwell Equations of Software -;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen -;;; -;;; 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 . - -;;; 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))))) diff --git a/mes/module/srfi/srfi-9/gnu.mes b/mes/module/srfi/srfi-9/gnu.mes new file mode 120000 index 00000000..d5857c78 --- /dev/null +++ b/mes/module/srfi/srfi-9/gnu.mes @@ -0,0 +1 @@ +gnu-vector.mes \ No newline at end of file diff --git a/src/hash.c b/src/hash.c index ea91a81d..c334103b 100644 --- a/src/hash.c +++ b/src/hash.c @@ -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 (""), fields, cell_unspecified); } SCM diff --git a/src/module.c b/src/module.c index 92b0d8ca..001efd20 100644 --- a/src/module.c +++ b/src/module.c @@ -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 (""), fields, cell_unspecified); } SCM