[Guile-commits] 02/07: Use make-struct/no-tail instead of make-struct

[Andy Wingo]

wingo pushed a commit to branch stable-2.2
in repository guile.

commit dd11b8216263aa9e79420a71e01c3cd210b19f10
Author: Andy Wingo <address@hidden>
Date:   Wed Sep 20 22:07:18 2017 +0200

    Use make-struct/no-tail instead of make-struct
    
    * module/ice-9/boot-9.scm:
    * module/language/cps/effects-analysis.scm:
    * module/language/elisp/falias.scm:
    * module/language/tree-il.scm:
    * module/language/tree-il/primitives.scm:
    * module/rnrs/records/procedural.scm:
    * module/srfi/srfi-35.scm:
    * module/system/base/syntax.scm: Change uses of make-struct to
      make-struct/no-tail.
---
 module/ice-9/boot-9.scm                  | 65 +++++++++++++++++---------------
 module/language/cps/effects-analysis.scm |  3 +-
 module/language/elisp/falias.scm         | 12 +++---
 module/language/tree-il.scm              |  4 +-
 module/language/tree-il/primitives.scm   | 13 ++-----
 module/rnrs/records/procedural.scm       | 37 +++++++++---------
 module/srfi/srfi-35.scm                  | 22 +++++------
 module/system/base/syntax.scm            |  2 +-
 8 files changed, 78 insertions(+), 80 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a70cd11..7f8962b 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  Free Software Foundation, Inc.
+;;;; Copyright (C) 1995-2014, 2016-2017  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
@@ -1236,7 +1236,7 @@ VALUE."
              (else
               (lambda args
                 (if (= (length args) nfields)
-                    (apply make-struct rtd 0 args)
+                    (apply make-struct/no-tail rtd args)
                     (scm-error 'wrong-number-of-args
                                (format #f "make-~a" type-name)
                                "Wrong number of arguments" '() #f)))))))))
@@ -1255,13 +1255,14 @@ VALUE."
         (loop (cdr fields) (+ 1 off)))))
     (display ">" p))
 
-  (let ((rtd (make-struct record-type-vtable 0
-                          (make-struct-layout
-                           (apply string-append
-                                  (map (lambda (f) "pw") fields)))
-                          (or printer default-record-printer)
-                          type-name
-                          (copy-tree fields))))
+  (let ((rtd (make-struct/no-tail
+              record-type-vtable
+              (make-struct-layout
+               (apply string-append
+                      (map (lambda (f) "pw") fields)))
+              (or printer default-record-printer)
+              type-name
+              (copy-tree fields))))
     (struct-set! rtd (+ vtable-offset-user 2)
                  (make-constructor rtd (length fields)))
     ;; Temporary solution: Associate a name to the record type descriptor
@@ -1286,7 +1287,8 @@ VALUE."
       (struct-ref rtd (+ 2 vtable-offset-user))
       (primitive-eval
        `(lambda ,field-names
-          (make-struct ',rtd 0 ,@(map (lambda (f)
+          (make-struct/no-tail ',rtd
+                               ,@(map (lambda (f)
                                         (if (memq f field-names)
                                             f
                                             #f))
@@ -1337,7 +1339,7 @@ VALUE."
 
 (define <parameter>
   ;; Three fields: the procedure itself, the fluid, and the converter.
-  (make-struct <applicable-struct-vtable> 0 'pwprpr))
+  (make-struct/no-tail <applicable-struct-vtable> 'pwprpr))
 (set-struct-vtable-name! <parameter> '<parameter>)
 
 (define* (make-parameter init #:optional (conv (lambda (x) x)))
@@ -1370,13 +1372,14 @@ including INIT, the initial value.  The default CONV 
procedure is the
 identity procedure.  CONV is commonly used to ensure some set of
 invariants on the values that a parameter may have."
   (let ((fluid (make-fluid (conv init))))
-    (make-struct <parameter> 0
-                 (case-lambda
-                   (() (fluid-ref fluid))
-                   ((x) (let ((prev (fluid-ref fluid)))
-                          (fluid-set! fluid (conv x))
-                          prev)))
-                 fluid conv)))
+    (make-struct/no-tail
+     <parameter>
+     (case-lambda
+      (() (fluid-ref fluid))
+      ((x) (let ((prev (fluid-ref fluid)))
+             (fluid-set! fluid (conv x))
+             prev)))
+     fluid conv)))
 
 (define (parameter? x)
   (and (struct? x) (eq? (struct-vtable x) <parameter>)))
@@ -1415,13 +1418,14 @@ If the parameter is rebound in some dynamic extent, 
perhaps via
 `parameterize', the new value will be run through the optional CONV
 procedure, as with any parameter.  Note that unlike `make-parameter',
 CONV is not applied to the initial value."
-  (make-struct <parameter> 0
-               (case-lambda
-                 (() (fluid-ref fluid))
-                 ((x) (let ((prev (fluid-ref fluid)))
-                        (fluid-set! fluid (conv x))
-                        prev)))
-               fluid conv))
+  (make-struct/no-tail
+   <parameter>
+   (case-lambda
+    (() (fluid-ref fluid))
+    ((x) (let ((prev (fluid-ref fluid)))
+           (fluid-set! fluid (conv x))
+           prev)))
+   fluid conv))
 
 
 
@@ -1953,11 +1957,12 @@ name extensions listed in %load-extensions."
              (constructor rtd type-name fields
                           #`(begin
                               (define #,rtd
-                                (make-struct record-type-vtable 0
-                                             '#,(make-layout)
-                                             #,printer
-                                             '#,type-name
-                                             '#,(field-list fields)))
+                                (make-struct/no-tail
+                                 record-type-vtable
+                                 '#,(make-layout)
+                                 #,printer
+                                 '#,type-name
+                                 '#,(field-list fields)))
                               (set-struct-vtable-name! #,rtd '#,type-name)))))
 
          (syntax-case x ()
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 4eff0d2..1cc03c0 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -1,6 +1,6 @@
 ;;; Effects analysis on CPS
 
-;; Copyright (C) 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2015, 2017 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
@@ -347,7 +347,6 @@ is or might be a read or a write to the same location as A."
 (define-primitive-effects* constants
   ((allocate-struct vt n)          (&allocate &struct)         &type-check)
   ((allocate-struct/immediate v n) (&allocate &struct)         &type-check)
-  ((make-struct vt ntail . _)      (&allocate &struct)         &type-check)
   ((make-struct/no-tail vt . _)    (&allocate &struct)         &type-check)
   ((struct-ref s n)                (read-struct-field n constants) &type-check)
   ((struct-ref/immediate s n)      (read-struct-field n constants) &type-check)
diff --git a/module/language/elisp/falias.scm b/module/language/elisp/falias.scm
index f043548..60eb9f1 100644
--- a/module/language/elisp/falias.scm
+++ b/module/language/elisp/falias.scm
@@ -5,11 +5,11 @@
             falias-object))
 
 (define <falias-vtable>
-  (make-struct <applicable-struct-vtable>
-               0
-               (make-struct-layout "pwpw")
-               (lambda (object port)
-                 (format port "#<falias ~S>" (falias-object object)))))
+  (make-struct/no-tail
+   <applicable-struct-vtable>
+   (make-struct-layout "pwpw")
+   (lambda (object port)
+     (format port "#<falias ~S>" (falias-object object)))))
 
 (set-struct-vtable-name! <falias-vtable> 'falias)
 
@@ -18,7 +18,7 @@
        (eq? (struct-vtable object) <falias-vtable>)))
 
 (define (make-falias f object)
-  (make-struct <falias-vtable> 0 f object))
+  (make-struct/no-tail <falias-vtable> f object))
 
 (define (falias-function object)
   (struct-ref object 0))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index dcd0346..5fb0ce0 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,4 +1,4 @@
-;;;;   Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software 
Foundation, Inc.
+;;;;   Copyright (C) 2009-2014, 2017 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
@@ -86,7 +86,7 @@
                    (let lp ((n 0) (fields fields)
                             (out (cons*
                                   #`(define (#,ctor #,@sfields)
-                                      (make-struct #,type 0 #,@sfields))
+                                      (make-struct/no-tail #,type #,@sfields))
                                   #`(define (#,pred x)
                                       (and (struct? x)
                                            (eq? (struct-vtable x) #,type)))
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index 90c1d2d..e716714 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -1,6 +1,6 @@
 ;;; open-coding primitive procedures
 
-;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software 
Foundation, Inc.
+;; Copyright (C) 2009-2015, 2017 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
@@ -94,7 +94,7 @@
 
     string-length string-ref string-set!
 
-    allocate-struct struct-vtable make-struct struct-ref struct-set!
+    allocate-struct struct-vtable make-struct/no-tail struct-ref struct-set!
 
     bytevector-length
 
@@ -139,7 +139,7 @@
 (define *primitive-constructors*
   ;; Primitives that return a fresh object.
   '(acons cons cons* list vector make-vector
-    allocate-struct make-struct make-struct/no-tail
+    allocate-struct make-struct/no-tail
     make-prompt-tag))
 
 (define *primitive-accessors*
@@ -467,13 +467,6 @@
 (define-primitive-expander call/cc (proc)
   (call-with-current-continuation proc))
 
-(define-primitive-expander make-struct (vtable tail-size . args)
-  (if (and (const? tail-size)
-           (let ((n (const-exp tail-size)))
-             (and (number? n) (exact? n) (zero? n))))
-      (make-struct/no-tail vtable . args)
-      #f))
-
 (define-primitive-expander u8vector-ref (vec i)
   (bytevector-u8-ref vec i))
 (define-primitive-expander u8vector-set! (vec i x)
diff --git a/module/rnrs/records/procedural.scm 
b/module/rnrs/records/procedural.scm
index 6976eeb..2bd9088 100644
--- a/module/rnrs/records/procedural.scm
+++ b/module/rnrs/records/procedural.scm
@@ -1,6 +1,6 @@
 ;;; procedural.scm --- Procedural interface to R6RS records
 
-;;      Copyright (C) 2010 Free Software Foundation, Inc.
+;;      Copyright (C) 2010, 2017 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
@@ -36,7 +36,7 @@
                         and=>
                        throw
                        display
-                       make-struct 
+                       make-struct/no-tail
                        make-vtable 
                        map
                        simple-format
@@ -125,7 +125,7 @@
                (and=> (struct-ref obj 0) private-record-predicate))))
 
     (define (field-binder parent-struct . args)
-      (apply make-struct (cons* late-rtd 0 parent-struct args)))
+      (apply make-struct/no-tail late-rtd parent-struct args))
 
     (if (and parent (struct-ref parent rtd-index-sealed?))
        (r6rs-raise (make-assertion-violation)))
@@ -150,23 +150,24 @@
              matching-rtd
              (r6rs-raise (make-assertion-violation)))
           
-         (let ((rtd (make-struct record-type-vtable 0
+         (let ((rtd (make-struct/no-tail
+                      record-type-vtable
 
-                                  fields-layout
-                                  (lambda (obj port)
-                                    (simple-format 
-                                     port "#<r6rs:record:~A>" name))
+                      fields-layout
+                      (lambda (obj port)
+                        (simple-format 
+                         port "#<r6rs:record:~A>" name))
                                  
-                                 name
-                                 uid
-                                 parent 
-                                 sealed? 
-                                 opaque?
+                      name
+                      uid
+                      parent 
+                      sealed? 
+                      opaque?
                                  
-                                 private-record-predicate
-                                 field-names
-                                  fields-bit-field
-                                 field-binder)))
+                      private-record-predicate
+                      field-names
+                      fields-bit-field
+                      field-binder)))
            (set! late-rtd rtd)
            (if uid (hashq-set! uid-table uid rtd))
            rtd))))
@@ -194,7 +195,7 @@
           (prot (or protocol (if pcd 
                                  default-inherited-protocol 
                                  default-protocol))))
-      (make-struct record-constructor-vtable 0 rtd pcd prot)))
+      (make-struct/no-tail record-constructor-vtable rtd pcd prot)))
 
   (define (record-constructor rctd)
     (let* ((rtd (struct-ref rctd rctd-index-rtd))
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 8f86bce..224c6af 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -1,6 +1,6 @@
 ;;; srfi-35.scm --- Conditions                 -*- coding: utf-8 -*-
 
-;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2011, 2017 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
@@ -58,10 +58,10 @@
     s))
 
 (define (%make-condition-type layout id parent all-fields)
-  (let ((struct (make-struct %condition-type-vtable 0
-                             (make-struct-layout layout) ;; layout
-                             print-condition             ;; printer
-                             id parent all-fields)))
+  (let ((struct (make-struct/no-tail %condition-type-vtable
+                                     (make-struct-layout layout) ;; layout
+                                     print-condition             ;; printer
+                                     id parent all-fields)))
 
     ;; Hack to associate STRUCT with a name, providing a better name for
     ;; GOOPS classes as returned by `class-of' et al.
@@ -202,7 +202,7 @@ supertypes."
              "Wrong type argument: ~S" c)))
 
 (define (make-condition-from-values type values)
-  (apply make-struct type 0 values))
+  (apply make-struct/no-tail type values))
 
 (define (make-condition type . field+value)
   "Return a new condition of type TYPE with fields initialized as specified
@@ -332,11 +332,11 @@ by C."
 
 (define &condition
   ;; The root condition type.
-  (make-struct %condition-type-vtable 0
-              (make-struct-layout "")
-              (lambda (c port)
-                (display "<&condition>"))
-              '&condition #f '() '()))
+  (make-struct/no-tail %condition-type-vtable
+                       (make-struct-layout "")
+                       (lambda (c port)
+                         (display "<&condition>"))
+                       '&condition #f '() '()))
 
 (define-condition-type &message &condition
   message-condition?
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 1cabbbc..0bc16e5 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -80,7 +80,7 @@
                                                    (set! ,tail (cdr ,tail))
                                                    _x)))))
                         opts)
-               (make-struct ,name 0 ,@slot-names))))
+               (make-struct/no-tail ,name ,@slot-names))))
        (define ,(symbol-append stem '?) (record-predicate ,name))
        ,@(map (lambda (sname)
                 `(define ,(symbol-append stem '- sname)