diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 39d313f63..8bf724824 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1189,6 +1189,16 @@ VALUE." +;;; {IOTA functions: generating lists of numbers} +;;; + +(define (iota n) + (let loop ((count (1- n)) (result '())) + (if (< count 0) result + (loop (1- count) (cons count result))))) + + + ;;; {Structs} ;;; @@ -1253,10 +1263,14 @@ 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 ...) - (make-struct rtd 0 formal ...)))) + (let ((s (allocate-struct rtd n))) + (struct-set! s idx formal) + ... + s)))) (lp (1+ n))) '())) (else @@ -2211,14 +2225,21 @@ written into the port is returned." (cons #'f (field-list #'rest))))) (define (constructor rtd type-name fields exp) - (let ((ctor (make-id rtd type-name '-constructor)) - (args (field-list fields))) + (let* ((ctor (make-id rtd type-name '-constructor)) + (args (field-list fields)) + (n (length fields)) + (slots (iota n))) (predicate rtd type-name fields #`(begin #,exp (define #,ctor (let ((rtd #,rtd)) (lambda #,args - (make-struct rtd 0 #,@args)))) + (let ((s (allocate-struct rtd #,n))) + #,@(map + (lambda (arg slot) + #`(struct-set! s #,slot #,arg)) + args slots) + s)))) (struct-set! #,rtd (+ vtable-offset-user 2) #,ctor))))) @@ -3496,16 +3517,6 @@ but it fails to load." -;;; {IOTA functions: generating lists of numbers} -;;; - -(define (iota n) - (let loop ((count (1- n)) (result '())) - (if (< count 0) result - (loop (1- count) (cons count result))))) - - - ;;; {While} ;;; ;;; with `continue' and `break'. diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm index d213a8656..2f092fe3b 100644 --- a/module/srfi/srfi-9.scm +++ b/module/srfi/srfi-9.scm @@ -1,6 +1,6 @@ ;;; srfi-9.scm --- define-record-type -;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012, 2013 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 @@ -156,7 +156,8 @@ ((_ type-name (getter-id ...) check? s (getter expr) ...) (every identifier? #'(getter ...)) (let ((copier-name (syntax->datum (make-copier-id #'type-name))) - (getter+exprs #'((getter expr) ...))) + (getter+exprs #'((getter expr) ...)) + (nfields (length #'(getter-id ...)))) (define (lookup id default-expr) (let ((results (filter (lambda (g+e) @@ -175,12 +176,16 @@ copier-name "unknown getter" x id))) #'(getter ...)) (with-syntax ((unsafe-expr - #`(make-struct - type-name 0 - #,@(map (lambda (getter index) - (lookup getter #`(struct-ref s #,index))) - #'(getter-id ...) - (iota (length #'(getter-id ...))))))) + #`(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))) (if (syntax->datum #'check?) #`(if (eq? (struct-vtable s) type-name) unsafe-expr @@ -204,26 +209,27 @@ ((name getter setter) #'getter))) field-specs)) - (define (constructor form type-name constructor-spec field-names) + (define (constructor form type-name constructor-spec field-ids) (syntax-case constructor-spec () ((ctor field ...) (every identifier? #'(field ...)) - (let ((ctor-args (map (lambda (field) - (let ((name (syntax->datum field))) - (or (memq name field-names) - (syntax-violation - (syntax-case form () - ((macro . args) - (syntax->datum #'macro))) - "unknown field in constructor spec" - form field)) - (cons name field))) - #'(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 ...)))) #`(define-inlinable #,constructor-spec - (make-struct #,type-name 0 - #,@(map (lambda (name) - (assq-ref ctor-args name)) - field-names))))))) + (let ((s (allocate-struct #,type-name #,(length field-ids)))) + #,@(map (lambda (arg slot) + #`(struct-set! s #,slot #,arg)) + #'(field ...) slots) + s)))))) (define (getters type-name getter-ids copier-id) (map (lambda (getter index) @@ -267,8 +273,9 @@ (iota (length field-specs)))) (define (record-layout immutable? count) - (let ((desc (if immutable? "pr" "pw"))) - (string-concatenate (make-list count desc)))) + ;; Mutability is expressed on the record level; all structs in the + ;; future will be mutable. + (string-concatenate (make-list count "pw"))) (syntax-case x () ((_ immutable? form type-name constructor-spec predicate-name @@ -300,12 +307,11 @@ (field-count (length field-ids)) (immutable? (syntax->datum #'immutable?)) (layout (record-layout immutable? field-count)) - (field-names (map syntax->datum field-ids)) (ctor-name (syntax-case #'constructor-spec () ((ctor args ...) #'ctor))) (copier-id (make-copier-id #'type-name))) #`(begin - #,(constructor #'form #'type-name #'constructor-spec field-names) + #,(constructor #'form #'type-name #'constructor-spec field-ids) (define type-name (let ((rtd (make-struct/no-tail