mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 12:20:20 +02:00
Code Activity

Introduce make-struct/simple

Browse source 
* libguile/struct.h:
* libguile/struct.c (scm_make_struct_simple): New function.
* module/ice-9/boot-9.scm (make-record-type): Recast in terms of
  make-struct/simple.
* module/ice-9/eval.scm (primitive-eval): Remove allocate-struct case.
* module/srfi/srfi-9.scm (%%set-fields, %define-record-type): Use
  make-struct/simple.
This commit is contained in:
Andy Wingo 2018-01-21 21:03:35 +01:00
parent 557acdbbba
commit 5084fa4858
5 changed files with 70 additions and 43 deletions
Download patch file Download diff file Expand all files Collapse all files

51
module/srfi/srfi-9.scm
View file

@ -1,7 +1,7 @@
;;; srfi-9.scm --- define-record-type
;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012,
;; 2013, 2014 Free Software Foundation, Inc.
;; 2013, 2014, 2018 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@ -180,16 +180,12 @@
copier-name "unknown getter" x id)))
#'(getter ...))
(with-syntax ((unsafe-expr
#`(let ((new (allocate-struct type-name #,nfields)))
#,@(map (lambda (getter index)
#`(struct-set!
new
#,index
#,(lookup getter
#`(struct-ref s #,index))))
#'(getter-id ...)
(iota nfields))
new)))
#`(make-struct/simple
type-name
#,@(map (lambda (getter index)
(lookup getter #`(struct-ref s #,index)))
#'(getter-id ...)
(iota nfields)))))
(if (syntax->datum #'check?)
#`(if (eq? (struct-vtable s) type-name)
unsafe-expr
@ -217,23 +213,24 @@
(syntax-case constructor-spec ()
((ctor field ...)
(every identifier? #'(field ...))
(let ((slots (map (lambda (field)
(or (list-index (lambda (x)
(free-identifier=? x field))
field-ids)
(syntax-violation
(syntax-case form ()
((macro . args)
(syntax->datum #'macro)))
"unknown field in constructor spec"
form field)))
#'(field ...))))
(letrec* ((id-list-contains?
(lambda (id-list id)
(and (not (null? id-list))
(or (free-identifier=? (car id-list) id)
(id-list-contains? (cdr id-list) id)))))
(inits (map (lambda (id)
(and (id-list-contains? #'(field ...) id) id))
field-ids)))
(for-each
(lambda (field)
(unless (id-list-contains? field-ids field)
(syntax-violation
(syntax-case form () ((macro . args) (syntax->datum #'macro)))
"unknown field in constructor spec"
form field)))
#'(field ...))
#`(define-inlinable #,constructor-spec
(let ((s (allocate-struct #,type-name #,(length field-ids))))
#,@(map (lambda (arg slot)
#`(struct-set! s #,slot #,arg))
#'(field ...) slots)
s))))))
(make-struct/simple #,type-name #,@inits))))))
(define (getters type-name getter-ids copier-id)
(map (lambda (getter index)