mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Use make-struct/no-tail instead of make-struct

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2017-09-20 22:07:18 +02:00
parent da9da0eca4
commit dd11b82162
8 changed files with 78 additions and 80 deletions
Download patch file Download diff file Expand all files Collapse all files

65
module/ice-9/boot-9.scm
View file

@ -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 ()

3
module/language/cps/effects-analysis.scm
View file

@ -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)

12
module/language/elisp/falias.scm
View file

@ -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))

4
module/language/tree-il.scm
View file

@ -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)))

13
module/language/tree-il/primitives.scm
View file

@ -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)

37
module/rnrs/records/procedural.scm
View file

@ -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))

22
module/srfi/srfi-35.scm
View file

@ -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?

2
module/system/base/syntax.scm
View file

@ -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)