diff options
author | Andy Wingo <wingo@pobox.com> | 2018-01-21 21:03:35 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2018-01-21 21:03:35 +0100 |
commit | 5084fa4858c0fa153c7c9fd5db3625cbc90470df (patch) | |
tree | 995fb5f86b8a99facf964bb26bb1bf129b3bd7b0 /module | |
parent | 557acdbbba9e3bcc1108d81cbf8c2f7c14fcb29a (diff) | |
download | guile-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.
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/boot-9.scm | 15 | ||||
-rw-r--r-- | module/ice-9/eval.scm | 4 | ||||
-rw-r--r-- | module/srfi/srfi-9.scm | 51 |
3 files changed, 29 insertions, 41 deletions
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) |