summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-09-22 11:59:51 +0200
committerAndy Wingo <wingo@pobox.com>2017-09-22 12:02:25 +0200
commit2f9ad7d9bcd1f787e324158a1ee402d111e8608e (patch)
tree7a79123f736074bfee46574e9067dd6702b39ff7 /module
parented549da23078657836e359d9d9ef3c6bd01cd738 (diff)
parentc7c7588f2416624319be2a037056ba8bb1c054e7 (diff)
downloadguile-2f9ad7d9bcd1f787e324158a1ee402d111e8608e.tar.gz
Merge stable-2.2 into master
This commit resolves conflicts by removing the deprecated make-struct.
Diffstat (limited to 'module')
-rw-r--r--module/ice-9/boot-9.scm73
-rw-r--r--module/ice-9/psyntax-pp.scm56
-rw-r--r--module/ice-9/psyntax.scm5
-rw-r--r--module/language/cps/effects-analysis.scm3
-rw-r--r--module/language/elisp/falias.scm12
-rw-r--r--module/language/tree-il.scm4
-rw-r--r--module/language/tree-il/primitives.scm13
-rw-r--r--module/rnrs/records/procedural.scm37
-rw-r--r--module/srfi/srfi-35.scm22
-rw-r--r--module/system/base/syntax.scm2
10 files changed, 114 insertions, 113 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 5af2950f2..c2d3a2625 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
@@ -208,14 +208,6 @@ This is handy for tracing function calls, e.g.:
-;;; {Structs}
-;;;
-
-(define (make-struct/no-tail vtable . args)
- (apply make-struct vtable 0 args))
-
-
-
;;; {map and for-each}
;;;
@@ -1233,7 +1225,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)))))))))
@@ -1252,13 +1244,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
@@ -1283,7 +1276,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))
@@ -1334,7 +1328,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)))
@@ -1367,13 +1361,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>)))
@@ -1412,13 +1407,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))
@@ -1946,11 +1942,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/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index e2ebeced1..be0f524c1 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -8,27 +8,41 @@
(syntax-module (module-ref (current-module) 'syntax-module)))
(letrec*
((make-void
- (lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src)))
+ (lambda (src)
+ (make-struct/no-tail (vector-ref %expanded-vtables 0) src)))
(make-const
(lambda (src exp)
- (make-struct (vector-ref %expanded-vtables 1) 0 src exp)))
+ (make-struct/no-tail (vector-ref %expanded-vtables 1) src exp)))
(make-primitive-ref
(lambda (src name)
- (make-struct (vector-ref %expanded-vtables 2) 0 src name)))
+ (make-struct/no-tail (vector-ref %expanded-vtables 2) src name)))
(make-lexical-ref
(lambda (src name gensym)
- (make-struct (vector-ref %expanded-vtables 3) 0 src name gensym)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 3)
+ src
+ name
+ gensym)))
(make-lexical-set
(lambda (src name gensym exp)
- (make-struct (vector-ref %expanded-vtables 4) 0 src name gensym exp)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 4)
+ src
+ name
+ gensym
+ exp)))
(make-module-ref
(lambda (src mod name public?)
- (make-struct (vector-ref %expanded-vtables 5) 0 src mod name public?)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 5)
+ src
+ mod
+ name
+ public?)))
(make-module-set
(lambda (src mod name public? exp)
- (make-struct
+ (make-struct/no-tail
(vector-ref %expanded-vtables 6)
- 0
src
mod
name
@@ -36,39 +50,37 @@
exp)))
(make-toplevel-ref
(lambda (src name)
- (make-struct (vector-ref %expanded-vtables 7) 0 src name)))
+ (make-struct/no-tail (vector-ref %expanded-vtables 7) src name)))
(make-toplevel-set
(lambda (src name exp)
- (make-struct (vector-ref %expanded-vtables 8) 0 src name exp)))
+ (make-struct/no-tail (vector-ref %expanded-vtables 8) src name exp)))
(make-toplevel-define
(lambda (src name exp)
- (make-struct (vector-ref %expanded-vtables 9) 0 src name exp)))
+ (make-struct/no-tail (vector-ref %expanded-vtables 9) src name exp)))
(make-conditional
(lambda (src test consequent alternate)
- (make-struct
+ (make-struct/no-tail
(vector-ref %expanded-vtables 10)
- 0
src
test
consequent
alternate)))
(make-call
(lambda (src proc args)
- (make-struct (vector-ref %expanded-vtables 11) 0 src proc args)))
+ (make-struct/no-tail (vector-ref %expanded-vtables 11) src proc args)))
(make-primcall
(lambda (src name args)
- (make-struct (vector-ref %expanded-vtables 12) 0 src name args)))
+ (make-struct/no-tail (vector-ref %expanded-vtables 12) src name args)))
(make-seq
(lambda (src head tail)
- (make-struct (vector-ref %expanded-vtables 13) 0 src head tail)))
+ (make-struct/no-tail (vector-ref %expanded-vtables 13) src head tail)))
(make-lambda
(lambda (src meta body)
- (make-struct (vector-ref %expanded-vtables 14) 0 src meta body)))
+ (make-struct/no-tail (vector-ref %expanded-vtables 14) src meta body)))
(make-lambda-case
(lambda (src req opt rest kw inits gensyms body alternate)
- (make-struct
+ (make-struct/no-tail
(vector-ref %expanded-vtables 15)
- 0
src
req
opt
@@ -80,9 +92,8 @@
alternate)))
(make-let
(lambda (src names gensyms vals body)
- (make-struct
+ (make-struct/no-tail
(vector-ref %expanded-vtables 16)
- 0
src
names
gensyms
@@ -90,9 +101,8 @@
body)))
(make-letrec
(lambda (src in-order? names gensyms vals body)
- (make-struct
+ (make-struct/no-tail
(vector-ref %expanded-vtables 17)
- 0
src
in-order?
names
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 08b3dae04..262b4e7d7 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -184,8 +184,9 @@
(sfields (map (lambda (f) (datum->syntax x f)) fields))
(ctor (datum->syntax x (symbol-append 'make- stem))))
(cons #`(define (#,ctor #,@sfields)
- (make-struct (vector-ref %expanded-vtables #,n) 0
- #,@sfields))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables #,n)
+ #,@sfields))
out)))
#`(begin #,@(reverse out))))))))
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 4eff0d261..1cc03c037 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 f043548fb..60eb9f1b5 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 dcd03466a..5fb0ce05f 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 90c1d2d1a..e716714fb 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 d925263d8..69c5d1c56 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
@@ -127,7 +127,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)))
@@ -152,23 +152,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))))
@@ -196,7 +197,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 0f0ab3c70..433032031 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
@@ -57,10 +57,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.
@@ -201,7 +201,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
@@ -331,11 +331,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 1cabbbcb7..0bc16e584 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)