andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

srfi-9: Fix record printing. 

* mes/module/srfi/srfi-9-struct.mes (print-record-type): New
procedure.
(make-record-type): Add 'printer' as new record type field and use
'print-record-type' as the struct printer.
(record-type-printer): New procedure.
(record-type-fields): Bump index for the 'printer' field.
(record-constructor): Use the record type printer as the struct
printer if it is defined.
(record-printer): Print the record type name instead of the raw
record type.
This commit is contained in:
Timothy Sample 2022-04-24 21:32:55 -06:00
parent f1447abeb3
commit 06cff14bfa
1 changed files with 17 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
mes/module/srfi/srfi-9-struct.mes
View File

@ -2,6 +2,7 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2022 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of GNU Mes.
;;;
@ -30,9 +31,16 @@
(define ,predicate ,(record-predicate type))
(define-record-accessors ,type ,@fields))))
(define (print-record-type o)
(display "#<record-type ")
(display (record-type-name o))
(display ">"))
(define (make-record-type type fields . printer)
(let ((printer (if (pair? printer) (car printer))))
(make-struct '<record-type> (cons type (list fields)) printer)))
(let ((printer (and (pair? printer) (car printer))))
(make-struct '<record-type>
(cons type (cons printer (list fields)))
print-record-type)))
(define (record-type? o)
(eq? (record-type-descriptor o) '<record-type>))
@ -43,11 +51,14 @@
(define (record-type-name o)
(struct-ref o 2))
(define (record-type-printer o)
(struct-ref o 3))
(define (record-type-descriptor o)
(struct-ref o 0))
(define (record-type-fields o)
(struct-ref o 3))
(struct-ref o 4))
(define (record-predicate type)
(lambda (o)
@ -60,20 +71,20 @@
(define (record-constructor type . field-names)
(let* ((fields (record-type-fields type))
(printer (or (record-type-printer type) record-printer))
(name (record-type-name type))
(field-names (if (null? field-names) fields
(car field-names))))
(lambda (. o)
(if (not (= (length o) (length field-names))) (error "wrong number of arguments for record-constructor")
(let ((rest (make-list (- (length fields) (length field-names)))))
(make-struct type (cons name (append o rest)) record-printer))))))
(make-struct type (cons name (append o rest)) printer))))))
(define record-printer *unspecified*) ; TODO
(define (record-printer o)
(display "#<")
(display (record-type-name o))
(let* ((vtable (struct-vtable o))
(fields (record-type-fields vtable)))
(display (record-type-name vtable))
(for-each (lambda (field)
(display " ")
(display field)