summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-01-21 21:03:35 +0100
committerAndy Wingo <wingo@pobox.com>2018-01-21 21:03:35 +0100
commit5084fa4858c0fa153c7c9fd5db3625cbc90470df (patch)
tree995fb5f86b8a99facf964bb26bb1bf129b3bd7b0
parent557acdbbba9e3bcc1108d81cbf8c2f7c14fcb29a (diff)
downloadguile-5084fa4858c0fa153c7c9fd5db3625cbc90470df.tar.gz
Introduce make-struct/simple
* 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.
-rw-r--r--libguile/struct.c40
-rw-r--r--libguile/struct.h3
-rw-r--r--module/ice-9/boot-9.scm15
-rw-r--r--module/ice-9/eval.scm4
-rw-r--r--module/srfi/srfi-9.scm51
5 files changed, 70 insertions, 43 deletions
diff --git a/libguile/struct.c b/libguile/struct.c
index e39f3c720..957776b28 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1996-2001, 2003-2004, 2006-2013, 2015,
- * 2017 Free Software Foundation, Inc.
+ * 2017-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 License
@@ -413,6 +413,44 @@ SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_make_struct_simple, "make-struct/simple", 1, 0, 1,
+ (SCM vtable, SCM init),
+ "Create a new structure.\n\n"
+ "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
+ "The @var{init1}, @dots{} arguments supply the initial values\n"
+ "for the structure's fields\n.\n"
+ "This is a restricted variant of @code{make-struct/no-tail}\n"
+ "which applies only if the structure has no unboxed fields.\n"
+ "@code{make-struct/simple} must be called with as many\n"
+ "@var{init} values as the struct has fields. No finalizer is set\n"
+ "on the instance, even if the vtable has a non-zero finalizer\n"
+ "field. No magical vtable fields are inherited.\n\n"
+ "The advantage of using @code{make-struct/simple} is that the\n"
+ "compiler can inline it, so it is faster. When in doubt though,\n"
+ "use @code{make-struct/no-tail}.")
+#define FUNC_NAME s_scm_make_struct_simple
+{
+ long i, n_init;
+ SCM ret;
+
+ SCM_VALIDATE_VTABLE (1, vtable);
+ n_init = scm_ilength (init);
+ if (n_init != SCM_VTABLE_SIZE (vtable))
+ SCM_MISC_ERROR ("Wrong number of initializers.", SCM_EOL);
+
+ ret = scm_words (SCM_UNPACK (vtable) | scm_tc3_struct, n_init + 1);
+
+ for (i = 0; i < n_init; i++, init = scm_cdr (init))
+ {
+ SCM_ASSERT (!SCM_VTABLE_FIELD_IS_UNBOXED (vtable, i),
+ vtable, 1, FUNC_NAME);
+ SCM_STRUCT_SLOT_SET (ret, i, scm_car (init));
+ }
+
+ return ret;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_make_struct_no_tail, "make-struct/no-tail", 1, 0, 1,
(SCM vtable, SCM init),
"Create a new structure.\n\n"
diff --git a/libguile/struct.h b/libguile/struct.h
index d88944cd7..66812eea8 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -4,7 +4,7 @@
#define SCM_STRUCT_H
/* Copyright (C) 1995,1997,1999-2001, 2006-2013, 2015,
- * 2017 Free Software Foundation, Inc.
+ * 2017-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 License
@@ -161,6 +161,7 @@ SCM_API SCM scm_make_struct_layout (SCM fields);
SCM_API SCM scm_struct_p (SCM x);
SCM_API SCM scm_struct_vtable_p (SCM x);
SCM_INTERNAL SCM scm_allocate_struct (SCM vtable, SCM n_words);
+SCM_INTERNAL SCM scm_make_struct_simple (SCM vtable, SCM init);
SCM_API SCM scm_make_struct_no_tail (SCM vtable, SCM init);
SCM_API SCM scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_inits,
scm_t_bits init, ...);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 9186f3017..022c57253 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 1995-2014, 2016-2017 Free Software Foundation, Inc.
+;;;; Copyright (C) 1995-2014, 2016-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
@@ -1211,14 +1211,10 @@ VALUE."
#,@(let lp ((n 0))
(if (< n *max-static-argument-count*)
(cons (with-syntax (((formal ...) (make-formals n))
- ((idx ...) (iota n))
(n n))
#'((n)
(lambda (formal ...)
- (let ((s (allocate-struct rtd n)))
- (struct-set! s idx formal)
- ...
- s))))
+ (make-struct/simple rtd formal ...))))
(lp (1+ n)))
'()))
(else
@@ -1919,12 +1915,7 @@ name extensions listed in %load-extensions."
(define #,ctor
(let ((rtd #,rtd))
(lambda #,args
- (let ((s (allocate-struct rtd #,n)))
- #,@(map
- (lambda (arg slot)
- #`(struct-set! s #,slot #,arg))
- args slots)
- s))))
+ (make-struct/simple rtd #,@args))))
(struct-set! #,rtd (+ vtable-offset-user 2)
#,ctor)))))
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index d21f59abd..41224517f 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2015, 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
@@ -157,7 +157,7 @@
a))
((a b)
(maybe-primcall (+ - * / ash logand logior logxor
- cons vector-ref struct-ref allocate-struct variable-set!)
+ cons vector-ref struct-ref variable-set!)
a b))
((a b c)
(maybe-primcall (vector-set! struct-set!) a b c))
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index 718986285..aee8be01c 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -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)