diff options
author | Andy Wingo <wingo@pobox.com> | 2017-09-22 11:59:51 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2017-09-22 12:02:25 +0200 |
commit | 2f9ad7d9bcd1f787e324158a1ee402d111e8608e (patch) | |
tree | 7a79123f736074bfee46574e9067dd6702b39ff7 /module | |
parent | ed549da23078657836e359d9d9ef3c6bd01cd738 (diff) | |
parent | c7c7588f2416624319be2a037056ba8bb1c054e7 (diff) | |
download | guile-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.scm | 73 | ||||
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 56 | ||||
-rw-r--r-- | module/ice-9/psyntax.scm | 5 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 3 | ||||
-rw-r--r-- | module/language/elisp/falias.scm | 12 | ||||
-rw-r--r-- | module/language/tree-il.scm | 4 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 13 | ||||
-rw-r--r-- | module/rnrs/records/procedural.scm | 37 | ||||
-rw-r--r-- | module/srfi/srfi-35.scm | 22 | ||||
-rw-r--r-- | module/system/base/syntax.scm | 2 |
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) |