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)