mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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.
This commit is contained in:
Andy Wingo
parent
557acdbbba
commit
5084fa4858
5 changed files with 70 additions and 43 deletions
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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, ...);
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
#`(make-struct/simple
|
||||
type-name
|
||||
#,@(map (lambda (getter index)
|
||||
#`(struct-set!
|
||||
new
|
||||
#,index
|
||||
#,(lookup getter
|
||||
#`(struct-ref s #,index))))
|
||||
(lookup getter #`(struct-ref s #,index)))
|
||||
#'(getter-id ...)
|
||||
(iota nfields))
|
||||
new)))
|
||||
(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)
|
||||
(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)))
|
||||
(syntax-case form () ((macro . args) (syntax->datum #'macro)))
|
||||
"unknown field in constructor spec"
|
||||
form field)))
|
||||
#'(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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue