mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-18 09:40:25 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: libguile/array-handle.c libguile/deprecated.h libguile/inline.c libguile/inline.h module/ice-9/deprecated.scm module/language/tree-il/peval.scm
This commit is contained in:
Andy Wingo
commit
9b977c836b
36 changed files with 873 additions and 384 deletions
|
|
@ -627,12 +627,10 @@ file with the given name already exists, the effect is unspecified."
|
|||
datum
|
||||
(syntax->datum clause)
|
||||
(syntax->datum whole-expr)))
|
||||
(if (memv datum seen)
|
||||
(warn-datum 'duplicate-case-datum))
|
||||
(if (or (pair? datum)
|
||||
(array? datum)
|
||||
(generalized-vector? datum))
|
||||
(warn-datum 'bad-case-datum))
|
||||
(when (memv datum seen)
|
||||
(warn-datum 'duplicate-case-datum))
|
||||
(when (or (pair? datum) (array? datum))
|
||||
(warn-datum 'bad-case-datum))
|
||||
(cons datum seen))
|
||||
seen
|
||||
(map syntax->datum #'(datums ...)))))
|
||||
|
|
@ -966,6 +964,8 @@ information is unavailable."
|
|||
#'(define-macro macro doc (lambda args body1 body ...)))
|
||||
((_ (macro . args) body ...)
|
||||
#'(define-macro macro #f (lambda args body ...)))
|
||||
((_ macro transformer)
|
||||
#'(define-macro macro #f transformer))
|
||||
((_ macro doc transformer)
|
||||
(or (string? (syntax->datum #'doc))
|
||||
(not (syntax->datum #'doc)))
|
||||
|
|
|
|||
|
|
@ -431,6 +431,13 @@ top-level bindings from ENV and return the resulting expression."
|
|||
new))
|
||||
vars))
|
||||
|
||||
(define (fresh-temporaries ls)
|
||||
(map (lambda (elt)
|
||||
(let ((new (gensym "tmp ")))
|
||||
(record-new-temporary! 'tmp new 1)
|
||||
new))
|
||||
ls))
|
||||
|
||||
(define (assigned-lexical? sym)
|
||||
(var-set? (lookup-var sym)))
|
||||
|
||||
|
|
@ -508,7 +515,7 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(else
|
||||
(residualize-call))))
|
||||
|
||||
(define (inline-values exp src names gensyms body)
|
||||
(define (inline-values src exp nmin nmax consumer)
|
||||
(let loop ((exp exp))
|
||||
(match exp
|
||||
;; Some expression types are always singly-valued.
|
||||
|
|
@ -524,17 +531,15 @@ top-level bindings from ENV and return the resulting expression."
|
|||
($ <toplevel-set>) ; could return zero values in
|
||||
($ <toplevel-define>) ; the future
|
||||
($ <module-set>) ;
|
||||
($ <dynset>)) ;
|
||||
(and (= (length names) 1)
|
||||
(make-let src names gensyms (list exp) body)))
|
||||
(($ <primcall> src (? singly-valued-primitive? name))
|
||||
(and (= (length names) 1)
|
||||
(make-let src names gensyms (list exp) body)))
|
||||
($ <dynset>) ;
|
||||
($ <primcall> src (? singly-valued-primitive?)))
|
||||
(and (<= nmin 1) (or (not nmax) (>= nmax 1))
|
||||
(make-call src (make-lambda #f '() consumer) (list exp))))
|
||||
|
||||
;; Statically-known number of values.
|
||||
(($ <primcall> src 'values vals)
|
||||
(and (= (length names) (length vals))
|
||||
(make-let src names gensyms vals body)))
|
||||
(and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals)))
|
||||
(make-call src (make-lambda #f '() consumer) vals)))
|
||||
|
||||
;; Not going to copy code into both branches.
|
||||
(($ <conditional>) #f)
|
||||
|
|
@ -692,6 +697,49 @@ top-level bindings from ENV and return the resulting expression."
|
|||
((vhash-assq var env) => cdr)
|
||||
(else (error "unbound var" var))))
|
||||
|
||||
;; Find a value referenced a specific number of times. This is a hack
|
||||
;; that's used for propagating fresh data structures like rest lists and
|
||||
;; prompt tags. Usually we wouldn't copy consed data, but we can do so in
|
||||
;; some special cases like `apply' or prompts if we can account
|
||||
;; for all of its uses.
|
||||
;;
|
||||
;; You don't want to use this in general because it introduces a slight
|
||||
;; nonlinearity by running peval again (though with a small effort and size
|
||||
;; counter).
|
||||
;;
|
||||
(define (find-definition x n-aliases)
|
||||
(cond
|
||||
((lexical-ref? x)
|
||||
(cond
|
||||
((lookup (lexical-ref-gensym x))
|
||||
=> (lambda (op)
|
||||
(let ((y (or (operand-residual-value op)
|
||||
(visit-operand op counter 'value 10 10)
|
||||
(operand-source op))))
|
||||
(cond
|
||||
((and (lexical-ref? y)
|
||||
(= (lexical-refcount (lexical-ref-gensym x)) 1))
|
||||
;; X is a simple alias for Y. Recurse, regardless of
|
||||
;; the number of aliases we were expecting.
|
||||
(find-definition y n-aliases))
|
||||
((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
|
||||
;; We found a definition that is aliased the right
|
||||
;; number of times. We still recurse in case it is a
|
||||
;; lexical.
|
||||
(values (find-definition y 1)
|
||||
op))
|
||||
(else
|
||||
;; We can't account for our aliases.
|
||||
(values #f #f))))))
|
||||
(else
|
||||
;; A formal parameter. Can't say anything about that.
|
||||
(values #f #f))))
|
||||
((= n-aliases 1)
|
||||
;; Not a lexical: success, but only if we are looking for an
|
||||
;; unaliased value.
|
||||
(values x #f))
|
||||
(else (values #f #f))))
|
||||
|
||||
(define (visit exp ctx)
|
||||
(loop exp env counter ctx))
|
||||
|
||||
|
|
@ -820,6 +868,30 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(begin
|
||||
(record-operand-use op)
|
||||
(make-lexical-set src name (operand-sym op) (for-value exp))))))
|
||||
(($ <let> src
|
||||
(names ... rest)
|
||||
(gensyms ... rest-sym)
|
||||
(vals ... ($ <primcall> _ 'list rest-args))
|
||||
($ <primcall> asrc (or 'apply '@apply)
|
||||
(proc args ...
|
||||
($ <lexical-ref> _
|
||||
(? (cut eq? <> rest))
|
||||
(? (lambda (sym)
|
||||
(and (eq? sym rest-sym)
|
||||
(= (lexical-refcount sym) 1))))))))
|
||||
(let* ((tmps (make-list (length rest-args) 'tmp))
|
||||
(tmp-syms (fresh-temporaries tmps)))
|
||||
(for-tail
|
||||
(make-let src
|
||||
(append names tmps)
|
||||
(append gensyms tmp-syms)
|
||||
(append vals rest-args)
|
||||
(make-call
|
||||
asrc
|
||||
proc
|
||||
(append args
|
||||
(map (cut make-lexical-ref #f <> <>)
|
||||
tmps tmp-syms)))))))
|
||||
(($ <let> src names gensyms vals body)
|
||||
(define (compute-alias exp)
|
||||
;; It's very common for macros to introduce something like:
|
||||
|
|
@ -915,11 +987,13 @@ top-level bindings from ENV and return the resulting expression."
|
|||
;; reconstruct the let-values, pevaling the consumer.
|
||||
(let ((producer (for-values producer)))
|
||||
(or (match consumer
|
||||
(($ <lambda-case> src req #f #f #f () gensyms body #f)
|
||||
(cond
|
||||
((inline-values producer src req gensyms body)
|
||||
=> for-tail)
|
||||
(else #f)))
|
||||
(($ <lambda-case> src req opt rest #f inits gensyms body #f)
|
||||
(let* ((nmin (length req))
|
||||
(nmax (and (not rest) (+ nmin (if opt (length opt) 0)))))
|
||||
(cond
|
||||
((inline-values lv-src producer nmin nmax consumer)
|
||||
=> for-tail)
|
||||
(else #f))))
|
||||
(_ #f))
|
||||
(make-let-values lv-src producer (for-tail consumer)))))
|
||||
(($ <dynwind> src winder pre body post unwinder)
|
||||
|
|
@ -1102,15 +1176,30 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(make-primcall src 'values vals))))))
|
||||
|
||||
(($ <primcall> src (or 'apply '@apply) (proc args ... tail))
|
||||
(match (for-value tail)
|
||||
(($ <const> _ (args* ...))
|
||||
(let ((args* (map (lambda (x) (make-const #f x)) args*)))
|
||||
(for-tail (make-call src proc (append args args*)))))
|
||||
(($ <primcall> _ 'list args*)
|
||||
(for-tail (make-call src proc (append args args*))))
|
||||
(tail
|
||||
(let ((args (append (map for-value args) (list tail))))
|
||||
(make-primcall src '@apply (cons (for-value proc) args))))))
|
||||
(let lp ((tail* (find-definition tail 1)) (speculative? #t))
|
||||
(define (copyable? x)
|
||||
;; Inlining a result from find-definition effectively copies it,
|
||||
;; relying on the let-pruning to remove its original binding. We
|
||||
;; shouldn't copy non-constant expressions.
|
||||
(or (not speculative?) (constant-expression? x)))
|
||||
(match tail*
|
||||
(($ <const> _ (args* ...))
|
||||
(let ((args* (map (cut make-const #f <>) args*)))
|
||||
(for-tail (make-call src proc (append args args*)))))
|
||||
(($ <primcall> _ 'cons
|
||||
((and head (? copyable?)) (and tail (? copyable?))))
|
||||
(for-tail (make-primcall src '@apply
|
||||
(cons proc
|
||||
(append args (list head tail))))))
|
||||
(($ <primcall> _ 'list
|
||||
(and args* ((? copyable?) ...)))
|
||||
(for-tail (make-call src proc (append args args*))))
|
||||
(tail*
|
||||
(if speculative?
|
||||
(lp (for-value tail) #f)
|
||||
(let ((args (append (map for-value args) (list tail*))))
|
||||
(make-primcall src '@apply
|
||||
(cons (for-value proc) args))))))))
|
||||
|
||||
(($ <primcall> src (? constructor-primitive? name) args)
|
||||
(cond
|
||||
|
|
@ -1219,20 +1308,39 @@ top-level bindings from ENV and return the resulting expression."
|
|||
|
||||
(($ <call> src orig-proc orig-args)
|
||||
;; todo: augment the global env with specialized functions
|
||||
(let ((proc (visit orig-proc 'operator)))
|
||||
(let revisit-proc ((proc (visit orig-proc 'operator)))
|
||||
(match proc
|
||||
(($ <primitive-ref> _ name)
|
||||
(for-tail (make-primcall src name orig-args)))
|
||||
(($ <lambda> _ _
|
||||
($ <lambda-case> _ req opt #f #f inits gensyms body #f))
|
||||
;; Simple case: no rest, no keyword arguments.
|
||||
($ <lambda-case> _ req opt rest #f inits gensyms body #f))
|
||||
;; Simple case: no keyword arguments.
|
||||
;; todo: handle the more complex cases
|
||||
(let* ((nargs (length orig-args))
|
||||
(nreq (length req))
|
||||
(nopt (if opt (length opt) 0))
|
||||
(key (source-expression proc)))
|
||||
(define (inlined-call)
|
||||
(make-let src
|
||||
(append req
|
||||
(or opt '())
|
||||
(if rest (list rest) '()))
|
||||
gensyms
|
||||
(if (> nargs (+ nreq nopt))
|
||||
(append (list-head orig-args (+ nreq nopt))
|
||||
(list
|
||||
(make-primcall
|
||||
#f 'list
|
||||
(drop orig-args (+ nreq nopt)))))
|
||||
(append orig-args
|
||||
(drop inits (- nargs nreq))
|
||||
(if rest
|
||||
(list (make-const #f '()))
|
||||
'())))
|
||||
body))
|
||||
|
||||
(cond
|
||||
((or (< nargs nreq) (> nargs (+ nreq nopt)))
|
||||
((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
|
||||
;; An error, or effecting arguments.
|
||||
(make-call src (for-call orig-proc) (map for-value orig-args)))
|
||||
((or (and=> (find-counter key counter) counter-recursive?)
|
||||
|
|
@ -1256,12 +1364,7 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(lp (counter-prev counter)))))))
|
||||
|
||||
(log 'inline-recurse key)
|
||||
(loop (make-let src (append req (or opt '()))
|
||||
gensyms
|
||||
(append orig-args
|
||||
(drop inits (- nargs nreq)))
|
||||
body)
|
||||
env counter ctx))
|
||||
(loop (inlined-call) env counter ctx))
|
||||
(else
|
||||
;; An integration at the top-level, the first
|
||||
;; recursion of a recursive procedure, or a nested
|
||||
|
|
@ -1292,12 +1395,7 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(make-top-counter effort-limit operand-size-limit
|
||||
abort key))))
|
||||
(define result
|
||||
(loop (make-let src (append req (or opt '()))
|
||||
gensyms
|
||||
(append orig-args
|
||||
(drop inits (- nargs nreq)))
|
||||
body)
|
||||
env new-counter ctx))
|
||||
(loop (inlined-call) env new-counter ctx))
|
||||
|
||||
(if counter
|
||||
;; The nested inlining attempt succeeded.
|
||||
|
|
@ -1307,6 +1405,31 @@ top-level bindings from ENV and return the resulting expression."
|
|||
|
||||
(log 'inline-end result exp)
|
||||
result)))))
|
||||
(($ <let> _ _ _ vals _)
|
||||
;; Attempt to inline `let' in the operator position.
|
||||
;;
|
||||
;; We have to re-visit the proc in value mode, since the
|
||||
;; `let' bindings might have been introduced or renamed,
|
||||
;; whereas the lambda (if any) in operator position has not
|
||||
;; been renamed.
|
||||
(if (or (and-map constant-expression? vals)
|
||||
(and-map constant-expression? orig-args))
|
||||
;; The arguments and the let-bound values commute.
|
||||
(match (for-value orig-proc)
|
||||
(($ <let> lsrc names syms vals body)
|
||||
(log 'inline-let orig-proc)
|
||||
(for-tail
|
||||
(make-let lsrc names syms vals
|
||||
(make-call src body orig-args))))
|
||||
;; It's possible for a `let' to go away after the
|
||||
;; visit due to the fact that visiting a procedure in
|
||||
;; value context will prune unused bindings, whereas
|
||||
;; visiting in operator mode can't because it doesn't
|
||||
;; traverse through lambdas. In that case re-visit
|
||||
;; the procedure.
|
||||
(proc (revisit-proc proc)))
|
||||
(make-call src (for-call orig-proc)
|
||||
(map for-value orig-args))))
|
||||
(_
|
||||
(make-call src (for-call orig-proc) (map for-value orig-args))))))
|
||||
(($ <lambda> src meta body)
|
||||
|
|
@ -1365,37 +1488,6 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
|
||||
#t)
|
||||
(_ #f)))
|
||||
(define (find-definition x n-aliases)
|
||||
(cond
|
||||
((lexical-ref? x)
|
||||
(cond
|
||||
((lookup (lexical-ref-gensym x))
|
||||
=> (lambda (op)
|
||||
(let ((y (or (operand-residual-value op)
|
||||
(visit-operand op counter 'value 10 10))))
|
||||
(cond
|
||||
((and (lexical-ref? y)
|
||||
(= (lexical-refcount (lexical-ref-gensym x)) 1))
|
||||
;; X is a simple alias for Y. Recurse, regardless of
|
||||
;; the number of aliases we were expecting.
|
||||
(find-definition y n-aliases))
|
||||
((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
|
||||
;; We found a definition that is aliased the right
|
||||
;; number of times. We still recurse in case it is a
|
||||
;; lexical.
|
||||
(values (find-definition y 1)
|
||||
op))
|
||||
(else
|
||||
;; We can't account for our aliases.
|
||||
(values #f #f))))))
|
||||
(else
|
||||
;; A formal parameter. Can't say anything about that.
|
||||
(values #f #f))))
|
||||
((= n-aliases 1)
|
||||
;; Not a lexical: success, but only if we are looking for an
|
||||
;; unaliased value.
|
||||
(values x #f))
|
||||
(else (values #f #f))))
|
||||
|
||||
(let ((tag (for-value tag))
|
||||
(body (for-tail body)))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Extensions to SRFI-4
|
||||
|
||||
;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 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
|
||||
|
|
@ -101,14 +101,14 @@
|
|||
`(define (,(symbol-append 'any-> tag 'vector) obj)
|
||||
(cond ((,(symbol-append tag 'vector?) obj) obj)
|
||||
((pair? obj) (,(symbol-append 'list-> tag 'vector) obj))
|
||||
((generalized-vector? obj)
|
||||
(let* ((len (generalized-vector-length obj))
|
||||
((and (array? obj) (eqv? 1 (array-rank obj)))
|
||||
(let* ((len (array-length obj))
|
||||
(v (,(symbol-append 'make- tag 'vector) len)))
|
||||
(let lp ((i 0))
|
||||
(if (< i len)
|
||||
(begin
|
||||
(,(symbol-append tag 'vector-set!)
|
||||
v i (generalized-vector-ref obj i))
|
||||
v i (array-ref obj i))
|
||||
(lp (1+ i)))
|
||||
v))))
|
||||
(else (scm-error 'wrong-type-arg #f "" '() (list obj))))))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2010, 2011, 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
|
||||
|
|
@ -25,7 +25,7 @@
|
|||
float double
|
||||
short
|
||||
unsigned-short
|
||||
int unsigned-int long unsigned-long size_t
|
||||
int unsigned-int long unsigned-long size_t ssize_t ptrdiff_t
|
||||
int8 uint8
|
||||
uint16 int16
|
||||
uint32 int32
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; (texinfo) -- parsing of texinfo into SXML
|
||||
;;;;
|
||||
;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
|
||||
;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
|
||||
;;;;
|
||||
|
|
@ -187,6 +187,7 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS},
|
|||
(sample INLINE-TEXT)
|
||||
(samp INLINE-TEXT)
|
||||
(code INLINE-TEXT)
|
||||
(math INLINE-TEXT)
|
||||
(kbd INLINE-TEXT)
|
||||
(key INLINE-TEXT)
|
||||
(var INLINE-TEXT)
|
||||
|
|
|
|||
|
|
@ -135,7 +135,7 @@ each other. @xref{texinfo docbook sdocbook-flatten,,sdocbook-flatten},
|
|||
for more information."
|
||||
'(para programlisting informalexample indexterm variablelist
|
||||
orderedlist refsect1 refsect2 refsect3 refsect4 title example
|
||||
note itemizedlist))
|
||||
note itemizedlist informaltable))
|
||||
|
||||
(define (inline-command? command)
|
||||
(not (memq command *sdocbook-block-commands*)))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; (texinfo plain-text) -- rendering stexinfo as plain text
|
||||
;;;;
|
||||
;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
|
|
@ -238,6 +238,7 @@
|
|||
(sample ,code)
|
||||
(samp ,code)
|
||||
(code ,code)
|
||||
(math ,passthrough)
|
||||
(kbd ,code)
|
||||
(key ,key)
|
||||
(var ,var)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; (texinfo serialize) -- rendering stexinfo as texinfo
|
||||
;;;;
|
||||
;;;; Copyright (C) 2009, 2012 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2009, 2012, 2013 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
|
|
@ -185,7 +185,8 @@
|
|||
|
||||
(define (wrap strings)
|
||||
(fill-string (string-concatenate strings)
|
||||
#:line-width 72))
|
||||
#:line-width 72
|
||||
#:break-long-words? #f))
|
||||
|
||||
(define (paragraph exp lp command type formals args accum)
|
||||
(list* "\n\n"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue